[Git][ghc/ghc][wip/decode_cloned_stack] stack_comparison

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC


Commits:
898348cb by Sven Tennie at 2022-11-26T14:53:18+00:00
stack_comparison

- - - - -


2 changed files:

- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/tests/stack_comparison.hs


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -305,6 +305,7 @@ data StackFrame =
   CatchStmFrame { code :: CL.Closure, handler :: CL.Closure  } |
   CatchRetryFrame {running_alt_code :: Word, first_code :: CL.Closure, alt_code :: CL.Closure} |
   AtomicallyFrame { code :: CL.Closure, result :: CL.Closure} |
+  -- TODO: nextChunk could be a CL.Closure, too! (StackClosure)
   UnderflowFrame { nextChunk:: StackSnapshot } |
   StopFrame |
   RetSmall { knownRetSmallType :: SpecialRetSmall, payload :: [BitmapPayload]} |


=====================================
libraries/ghc-heap/tests/stack_comparison.hs
=====================================
@@ -1,5 +1,7 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE UnliftedFFITypes #-}
 
 module Main where
@@ -8,6 +10,8 @@ import Data.Array.Byte
 import GHC.Exts
 import GHC.Exts.DecodeStack
 import GHC.Exts.Heap
+import GHC.Exts.Heap (StgInfoTable (StgInfoTable))
+import GHC.Records
 import GHC.Stack.CloneStack
 import TestUtils
 
@@ -22,7 +26,9 @@ main = do
   let ba = foldStackToArrayClosure stack
   let s = I# (sizeofByteArray# b#)
       (ByteArray b#) = ba
-  print . show . toClosureTypes . toWords $ ba
+  print . show . wordsToClosureTypes . toWords $ ba
+  frames <- decodeStack stack
+  print $ show (concatMap stackFrameToClosureTypes frames)
 
 toWords :: ByteArray -> [Word]
 toWords ba@(ByteArray b#) =
@@ -38,8 +44,60 @@ toWords ba@(ByteArray b#) =
             w | w == 0 -> error "ByteArray contains no content!"
             w -> w - 1
 
-toClosureTypes :: [Word] -> [ClosureType]
-toClosureTypes = map (toEnum . fromIntegral)
+wordsToClosureTypes :: [Word] -> [ClosureType]
+wordsToClosureTypes = map (toEnum . fromIntegral)
 
 toInt# :: Int -> Int#
 toInt# (I# i#) = i#
+
+stackFrameToClosureTypes :: StackFrame -> [ClosureType]
+stackFrameToClosureTypes sf =
+  case sf of
+    (UpdateFrame {updatee, ..}) -> UPDATE_FRAME : getClosureTypes updatee
+    (CatchFrame {handler, ..}) -> CATCH_FRAME : getClosureTypes handler
+    (CatchStmFrame {code, handler}) -> CATCH_STM_FRAME : getClosureTypes code ++ getClosureTypes handler
+    (CatchRetryFrame {first_code, alt_code, ..}) -> CATCH_RETRY_FRAME : getClosureTypes first_code ++ getClosureTypes alt_code
+    (AtomicallyFrame {code, result}) -> ATOMICALLY_FRAME : getClosureTypes code ++ getClosureTypes result
+    (UnderflowFrame {..}) -> [UNDERFLOW_FRAME]
+    StopFrame -> [STOP_FRAME]
+    (RetSmall {payload, ..}) -> RET_SMALL : getBitmapClosureTypes payload
+    (RetBig {payload}) -> RET_BIG : getBitmapClosureTypes payload
+    (RetFun {fun, payload, ..}) -> RET_FUN : getClosureTypes fun ++ getBitmapClosureTypes payload
+    (RetBCO {instrs, literals, ptrs, payload, ..}) ->
+      RET_BCO : getClosureTypes instrs ++ getClosureTypes literals ++ getClosureTypes ptrs ++ getBitmapClosureTypes payload
+
+getClosureTypes :: Closure -> [ClosureType]
+getClosureTypes (ConstrClosure {info, ..}) = [tipe info]
+getClosureTypes (FunClosure {info, ..}) = [tipe info]
+getClosureTypes (ThunkClosure {info, ..}) = [tipe info]
+getClosureTypes (SelectorClosure {info, ..}) = [tipe info]
+getClosureTypes (PAPClosure {info, ..}) = [tipe info]
+getClosureTypes (APClosure {info, ..}) = [tipe info]
+getClosureTypes (APStackClosure {info, ..}) = [tipe info]
+getClosureTypes (IndClosure {info, ..}) = [tipe info]
+getClosureTypes (BCOClosure {info, ..}) = [tipe info]
+getClosureTypes (BlackholeClosure {info, ..}) = [tipe info]
+getClosureTypes (ArrWordsClosure {info, ..}) = [tipe info]
+getClosureTypes (MutArrClosure {info, ..}) = [tipe info]
+getClosureTypes (SmallMutArrClosure {info, ..}) = [tipe info]
+getClosureTypes (MVarClosure {info, ..}) = [tipe info]
+getClosureTypes (IOPortClosure {info, ..}) = [tipe info]
+getClosureTypes (MutVarClosure {info, ..}) = [tipe info]
+getClosureTypes (BlockingQueueClosure {info, ..}) = [tipe info]
+getClosureTypes (WeakClosure {info, ..}) = [tipe info]
+getClosureTypes (TSOClosure {info, ..}) = [tipe info]
+getClosureTypes (StackClosure {info, ..}) = [tipe info]
+getClosureTypes (OtherClosure {info, ..}) = [tipe info]
+getClosureTypes (UnsupportedClosure {info, ..}) = [tipe info]
+getClosureTypes _ = []
+
+getBitmapClosureTypes :: [BitmapPayload] -> [ClosureType]
+getBitmapClosureTypes bps =
+  reverse $
+    foldl
+      ( \acc p -> case p of
+          (Closure c) -> getClosureTypes c ++ acc
+          (Primitive _) -> acc
+      )
+      []
+      bps



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/898348cb14e3e5669f3628dbf5ea33ad68b2b812
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/20221126/29ae1029/attachment-0001.html>