[Git][ghc/ghc][wip/add-ddump-specialisations] Current call stack ids

[Finley McIlwaine (@FinleyMcIlwaine)]

Finley McIlwaine pushed to branch wip/add-ddump-specialisations at Glasgow Haskell Compiler / GHC


Commits:
ef43e134 by Finley McIlwaine at 2023-11-07T11:00:09-08:00
Current call stack ids

- - - - -


3 changed files:

- libraries/base/GHC/Exts.hs
- libraries/base/GHC/Stack.hs
- libraries/base/GHC/Stack/CCS.hsc


Changes:

=====================================
libraries/base/GHC/Exts.hs
=====================================
@@ -103,6 +103,7 @@ module GHC.Exts
 
         -- ** The call stack
         currentCallStack,
+        currentCallStackIds,
 
         -- * Ids with special behaviour
         inline, noinline, lazy, oneShot, considerAccessible,


=====================================
libraries/base/GHC/Stack.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Stack (
 
     -- * Profiling call stacks
     currentCallStack,
+    currentCallStackIds,
     whoCreated,
 
     -- * HasCallStack call stacks


=====================================
libraries/base/GHC/Stack/CCS.hsc
=====================================
@@ -19,6 +19,7 @@
 module GHC.Stack.CCS (
     -- * Call stacks
     currentCallStack,
+    currentCallStackIds,
     whoCreated,
 
     -- * Internals
@@ -29,6 +30,7 @@ module GHC.Stack.CCS (
     clearCCS,
     ccsCC,
     ccsParent,
+    ccId,
     ccLabel,
     ccModule,
     ccSrcSpan,
@@ -83,6 +85,9 @@ ccsCC p = peekByteOff p 4
 ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
 ccsParent p = peekByteOff p 8
 
+ccId :: Ptr CostCentre -> IO Word32
+ccId p = peekByteOff p 0
+
 ccLabel :: Ptr CostCentre -> IO CString
 ccLabel p = peekByteOff p 4
 
@@ -99,6 +104,10 @@ ccsCC p = (# peek CostCentreStack, cc) p
 ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
 ccsParent p = (# peek CostCentreStack, prevStack) p
 
+-- | Get the id of a 'CostCentre'.
+ccId :: Ptr CostCentre -> IO Word32
+ccId p = (# peek CostCentre, ccID) p
+
 -- | Get the label of a 'CostCentre'.
 ccLabel :: Ptr CostCentre -> IO CString
 ccLabel p = (# peek CostCentre, label) p
@@ -125,6 +134,19 @@ ccSrcSpan p = (# peek CostCentre, srcloc) p
 currentCallStack :: IO [String]
 currentCallStack = ccsToStrings =<< getCurrentCCS ()
 
+-- | Returns a @[Word32]@ representing the current call stack.  This
+-- can be useful for debugging.
+--
+-- The implementation uses the call-stack simulation maintained by the
+-- profiler, so it only works if the program was compiled with @-prof@
+-- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).
+-- Otherwise, the list returned is likely to be empty or
+-- uninformative.
+--
+-- @since 4.5.0.0
+currentCallStackIds :: IO [Word32]
+currentCallStackIds = ccsToIds =<< getCurrentCCS ()
+
 -- | Format a 'CostCentreStack' as a list of lines.
 ccsToStrings :: Ptr CostCentreStack -> IO [String]
 ccsToStrings ccs0 = go ccs0 []
@@ -141,6 +163,22 @@ ccsToStrings ccs0 = go ccs0 []
            then return acc
            else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
 
+-- | Format a 'CostCentreStack' as a list of cost centre IDs.
+ccsToIds :: Ptr CostCentreStack -> IO [Word32]
+ccsToIds ccs0 = go ccs0 []
+  where
+    go ccs acc
+     | ccs == nullPtr = return acc
+     | otherwise = do
+        cc <- ccsCC ccs
+        cc_id <- ccId cc
+        lbl <- GHC.peekCString utf8 =<< ccLabel cc
+        mdl <- GHC.peekCString utf8 =<< ccModule cc
+        parent <- ccsParent ccs
+        if (mdl == "MAIN" && lbl == "MAIN")
+           then return acc
+           else go parent (cc_id : acc)
+
 -- | Get the stack trace attached to an object.
 --
 -- @since 4.5.0.0



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef43e1342591ea537ff315c6008766312fa3fbf6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef43e1342591ea537ff315c6008766312fa3fbf6
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231107/23960ed7/attachment-0001.html>