Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: d4002865 by fendor at 2025-07-17T15:24:57+02:00 WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder - - - - - bf1f28d0 by fendor at 2025-07-17T15:25:01+02:00 WIP: base: extend Backtraces to allow configuration of stack decoders - - - - - 7235ceab by fendor at 2025-07-17T15:25:02+02:00 WIP: move iterator based stack decoder to ghc-internal - - - - - 25 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/cbits/Stack.cmm - libraries/ghc-heap/tests/stack-annotation/all.T - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs - + libraries/ghc-internal/cbits/HeapPrim.cmm - + libraries/ghc-internal/cbits/Stack.cmm - + libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - + libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs Changes: ===================================== libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs ===================================== @@ -3,65 +3,93 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ImplicitParams #-} -module GHC.Stack.Annotation.Experimental where +module GHC.Stack.Annotation.Experimental ( + IsStackAnnotation(..), + SomeStackAnnotation(..), + -- * Source Location annotations + SrcLocAnnotation, + UnknownSrcLocAnnotation, + -- * Stack annotations + annotateStack, + annotateShow, + annotateCallStack, + annotateStackM, + annotateStringM, + annotateStackShowM, + annotateCallStackM, + ) where import Data.Typeable import GHC.Exts import GHC.IO -import GHC.Internal.Stack.Types +import GHC.Internal.Stack +import GHC.Internal.Stack.Annotation -data StackAnnotation where - StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation +data StringAnnotation where + StringAnnotation :: String -> StringAnnotation -class IsStackAnnotation a where - display :: a -> String +instance IsStackAnnotation StringAnnotation where + displayStackAnnotation (StringAnnotation str) = str -instance IsStackAnnotation StackAnnotation where - display (StackAnnotation a) = show a +-- ---------------------------------------------------------------------------- +-- Source location annotations +-- ---------------------------------------------------------------------------- -newtype SrcLocAnno = MkSrcLocAnno SrcLoc +newtype SrcLocAnnotation = SrcLocAnnotation SrcLoc -data UnknownSrcLocAnno = UnknownSrcLocAnno +data UnknownSrcLocAnnotation = UnknownSrcLocAnnotation deriving Show -instance Show SrcLocAnno where - show (MkSrcLocAnno l) = - concat - [ srcLocPackage l - , ":" - , srcLocModule l - , " " - , srcLocFile l - , ":" - , show $ srcLocStartLine l - , "-" - , show $ srcLocStartCol l - , ":" - , show $ srcLocEndLine l - , "-" - , show $ srcLocEndCol l - ] - -instance IsStackAnnotation SrcLocAnno where - display = show - -instance IsStackAnnotation UnknownSrcLocAnno where - display UnknownSrcLocAnno = "UnknownSrcLocAnno" +instance Show SrcLocAnnotation where + show (SrcLocAnnotation l) = prettySrcLoc l + +instance IsStackAnnotation SrcLocAnnotation where + displayStackAnnotation = show + +instance IsStackAnnotation UnknownSrcLocAnnotation where + displayStackAnnotation UnknownSrcLocAnnotation = "<no location info>" + +-- ---------------------------------------------------------------------------- +-- Annotate the CallStack! +-- ---------------------------------------------------------------------------- {-# NOINLINE annotateStack #-} -annotateStack :: forall a b. (Typeable a, Show a) => a -> b -> b +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateStack :: forall a b. (Typeable a, IsStackAnnotation a) => a -> b -> b annotateStack ann b = unsafePerformIO $ annotateStackM ann (pure b) -annotateStackM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +{-# NOINLINE annotateCallStack #-} +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateCallStack :: HasCallStack => b -> b +annotateCallStack b = unsafePerformIO $ + annotateCallStackM (pure b) + +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateShow :: forall a b . (Typeable a, Show a) => a -> b -> b +annotateShow ann = + annotateStack (StringAnnotation $ show ann) + +annotateStackM :: forall a b . (Typeable a, IsStackAnnotation a) => a -> IO b -> IO b annotateStackM ann (IO act) = - IO $ \s -> annotateStack# (StackAnnotation ann) act s + IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s + +annotateStringM :: forall b . String -> IO b -> IO b +annotateStringM ann = + annotateStackM (StringAnnotation ann) + +annotateStackShowM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +annotateStackShowM ann = + annotateStringM (show ann) annotateCallStackM :: HasCallStack => IO a -> IO a annotateCallStackM act = let cs = getCallStack ?callStack in case cs of - [] -> annotateStackM UnknownSrcLocAnno act - [(_, srcLoc)] -> annotateStackM (MkSrcLocAnno srcLoc) act - (_:(_, srcLoc):_) -> annotateStackM (MkSrcLocAnno srcLoc) act + [] -> annotateStackM UnknownSrcLocAnnotation act + [(_, srcLoc)] -> annotateStackM (SrcLocAnnotation srcLoc) act + (_:(_, srcLoc):_) -> annotateStackM (SrcLocAnnotation srcLoc) act ===================================== libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ===================================== @@ -24,7 +24,7 @@ import Foreign -- | Read an InfoTable from the heap into a haskell type. -- WARNING: This code assumes it is passed a pointer to a "standard" info --- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- table. If tables_next_to_code is disabled, it will look 1 word before the -- start for the entry field. peekItbl :: Ptr StgInfoTable -> IO StgInfoTable peekItbl a0 = do ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Exts.Stack.Decode ( decodeStack, + decodeStackWithIpe, ) where @@ -23,10 +24,10 @@ import Data.Bits import Data.Maybe import Foreign import GHC.Exts -import GHC.Exts.Heap (Box (..)) import GHC.Exts.Heap.ClosureTypes import GHC.Exts.Heap.Closures - ( StackFrame, + ( Box (..), + StackFrame, GenStackFrame (..), StgStackClosure, GenStgStackClosure (..), @@ -36,6 +37,7 @@ import GHC.Exts.Heap.Closures import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Exts.Heap.InfoTable import GHC.Exts.Stack.Constants +import qualified GHC.Internal.InfoProv.Types as IPE import GHC.Stack.CloneStack import GHC.Word import Prelude @@ -150,14 +152,17 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter -foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable +-- | Get the 'StgInfoTable' of the stack frame. +-- Additionally, provides 'IPE.InfoProv' for the 'StgInfoTable' if there is any. +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe IPE.InfoProv) getInfoTableOnStack stackSnapshot# index = - let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) - in peekItbl infoTablePtr + let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) + in + (,) <$> peekItbl (Ptr itbl_struct#) <*> IPE.lookupIPE (Ptr itbl_ptr#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -276,18 +281,49 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = (bitmapWordPointerness size bitmap) unpackStackFrame :: StackFrameLocation -> IO StackFrame -unpackStackFrame (StackSnapshot stackSnapshot#, index) = do - info <- getInfoTableOnStack stackSnapshot# index +unpackStackFrame stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ info nextChunk -> do + stackClosure <- decodeStack nextChunk + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + ) + (\ frame _ -> pure frame) + +unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe IPE.InfoProv)] +unpackStackFrameWithIpe stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ _ nextChunk -> do + decodeStackWithIpe nextChunk + ) + (\ frame mIpe -> pure [(frame, mIpe)]) + +unpackStackFrameTo :: + StackFrameLocation -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> Maybe IPE.InfoProv -> IO a) -> + IO a +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do + (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info + unpackUnderflowFrame + (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: StgInfoTable -> IO StackFrame - unpackStackFrame' info = + unpackStackFrame' :: + StgInfoTable -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> IO a) -> + IO a + unpackStackFrame' info unpackUnderflowFrame mkStackFrameResult = case tipe info of RET_BCO -> do let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) -- The arguments begin directly after the payload's one element bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) - pure + mkStackFrameResult RetBCO { info_tbl = info, bco = bco', @@ -296,14 +332,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in - pure $ + mkStackFrameResult $ RetSmall { info_tbl = info, stack_payload = payload' } RET_BIG -> do payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload - pure $ + mkStackFrameResult $ RetBig { info_tbl = info, stack_payload = payload' @@ -315,7 +351,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do if isArgGenBigRetFunType stackSnapshot# index == True then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload - pure $ + mkStackFrameResult $ RetFun { info_tbl = info, retFunSize = retFunSize', @@ -325,31 +361,26 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do UPDATE_FRAME -> let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) in - pure $ + mkStackFrameResult $ UpdateFrame { info_tbl = info, updatee = updatee' } CATCH_FRAME -> do let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) - pure $ + mkStackFrameResult $ CatchFrame { info_tbl = info, handler = handler' } UNDERFLOW_FRAME -> do let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index - stackClosure <- decodeStack nextChunk' - pure $ - UnderflowFrame - { info_tbl = info, - nextChunk = stackClosure - } - STOP_FRAME -> pure $ StopFrame {info_tbl = info} + unpackUnderflowFrame info nextChunk' + STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) - pure $ + mkStackFrameResult $ AtomicallyFrame { info_tbl = info, atomicallyFrameCode = atomicallyFrameCode', @@ -360,7 +391,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) in - pure $ + mkStackFrameResult $ CatchRetryFrame { info_tbl = info, running_alt_code = running_alt_code', @@ -371,7 +402,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) in - pure $ + mkStackFrameResult $ CatchStmFrame { info_tbl = info, catchFrameCode = catchFrameCode', @@ -380,7 +411,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - pure $ + mkStackFrameResult $ AnnFrame { info_tbl = info, annotation = annotation @@ -410,19 +441,27 @@ type StackFrameLocation = (StackSnapshot, WordOffset) -- -- See /Note [Decoding the stack]/. decodeStack :: StackSnapshot -> IO StgStackClosure -decodeStack (StackSnapshot stack#) = do +decodeStack snapshot@(StackSnapshot stack#) = do + (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot + pure + GenStgStackClosure + { ssc_info = stackInfo, + ssc_stack_size = getStackFields stack#, + ssc_stack = ssc_stack + } + +decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe IPE.InfoProv)] +decodeStackWithIpe snapshot = + concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot + +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do info <- getInfoTableForStack stack# case tipe info of STACK -> do - let stack_size' = getStackFields stack# - sfls = stackFrameLocations stack# - stack' <- mapM unpackStackFrame sfls - pure $ - GenStgStackClosure - { ssc_info = info, - ssc_stack_size = stack_size', - ssc_stack = stack' - } + let sfls = stackFrameLocations stack# + stack' <- mapM unpackFrame sfls + pure (info, stack') _ -> error $ "Expected STACK closure, got " ++ show info where stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] ===================================== libraries/ghc-heap/cbits/Stack.cmm ===================================== @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { return (type); } -// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) -getInfoTableAddrzh(P_ stack, W_ offsetWords) { - P_ p, info; +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrszh(P_ stack, W_ offsetWords) { + P_ p, info_struct, info_ptr; p = StgStack_sp(stack) + WDS(offsetWords); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); - info = %GET_STD_INFO(UNTAG(p)); - - return (info); + info_struct = %GET_STD_INFO(UNTAG(p)); + info_ptr = %INFO_PTR(UNTAG(p)); + return (info_struct, info_ptr); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-heap/tests/stack-annotation/all.T ===================================== @@ -1,2 +1,4 @@ test('ann_frame001', normal, compile_and_run, ['']) test('ann_frame002', normal, compile_and_run, ['']) +test('ann_frame003', normal, compile_and_run, ['']) +test('ann_frame004', normal, compile_and_run, ['']) ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ===================================== @@ -7,7 +7,7 @@ import System.IO.Unsafe import Unsafe.Coerce hello :: Int -> Int -> Int -hello x y = annotateStack (x,y) $ +hello x y = annotateShow (x,y) $ decodeAndPrintAnnotationFrames $! x + y + 42 {-# OPAQUE hello #-} @@ -17,9 +17,9 @@ decodeAndPrintAnnotationFrames :: a -> a decodeAndPrintAnnotationFrames a = unsafePerformIO $ do stack <- GHC.Stack.CloneStack.cloneMyStack decoded <- GHC.Exts.Stack.Decode.decodeStack stack - print [ show a + print [ displayStackAnnotation a | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded - , StackAnnotation a <- pure $ unsafeCoerce ann + , SomeStackAnnotation a <- pure $ unsafeCoerce ann ] pure a @@ -30,13 +30,13 @@ main = do {-# INLINE tailCallEx #-} tailCallEx :: Int -> Int -> Int -tailCallEx a b = annotateStack "tailCallEx" $ foo a b +tailCallEx a b = annotateShow "tailCallEx" $ foo a b {-# INLINE foo #-} foo :: Int -> Int -> Int -foo a b = annotateStack "foo" $ bar $ a * b +foo a b = annotateShow "foo" $ bar $ a * b -bar c = annotateStack "bar" $ +bar c = annotateShow "bar" $ decodeAndPrintAnnotationFrames $ c + c ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ===================================== @@ -12,17 +12,7 @@ import qualified GHC.Internal.Stack.CloneStack as CloneStack import System.IO.Unsafe import Unsafe.Coerce - -{-# NOINLINE decodeAnnotationFrames #-} -decodeAnnotationFrames :: IO [String] -decodeAnnotationFrames = do - stack <- CloneStack.cloneMyStack - decoded <- Decode.decodeStack stack - pure - [ show a - | AnnFrame _ (Box ann) <- ssc_stack decoded - , StackAnnotation a <- [unsafeCoerce ann] - ] +import GHC.Exts.Heap.Closures (GenStgStackClosure) {-# NOINLINE printAnnotationStack #-} printAnnotationStack :: [String] -> IO () @@ -47,8 +37,8 @@ baz = annotateCallStackM $ do decodeAnnotationFrames >>= printAnnotationStack bar :: IO () -bar = annotateCallStackM $ annotateStackM "bar" $ do - putStrLn "Some more ork in bar" +bar = annotateCallStackM $ annotateStringM "bar" $ do + putStrLn "Some more work in bar" print (fib 21) decodeAnnotationFrames >>= printAnnotationStack @@ -56,3 +46,23 @@ fib :: Int -> Int fib n | n <= 1 = 1 | otherwise = fib (n - 1) + fib (n - 2) + +{-# NOINLINE decodeAnnotationFrames #-} +decodeAnnotationFrames :: IO [String] +decodeAnnotationFrames = do + stack <- CloneStack.cloneMyStack + decoded <- Decode.decodeStack stack + pure $ unwindStack decoded + +unwindStack :: GenStgStackClosure Box -> [String] +unwindStack stack_closure = + [ ann + | a <- ssc_stack stack_closure + , ann <- case a of + AnnFrame _ (Box ann) -> + [ displayStackAnnotation a + | SomeStackAnnotation a <- [unsafeCoerce ann] + ] + UnderflowFrame _ underflow_stack_closure -> unwindStack underflow_stack_closure + _ -> [] + ] ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -1,11 +1,11 @@ Start some work 10946 Annotation stack: -main:Main ann_frame002.hs:35-7:35-10 -main:Main ann_frame002.hs:35-3:35-6 +ann_frame002.hs:25:7 in main:Main +ann_frame002.hs:25:3 in main:Main Finish some work Some more ork in bar 17711 Annotation stack: -"bar" -main:Main ann_frame002.hs:50-7:50-25 +bar +ann_frame002.hs:40:7 in main:Main ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs ===================================== @@ -0,0 +1,28 @@ + +import GHC.Stack.Annotation.Experimental +import Control.Exception.Backtrace + +hello :: Int -> Int -> Int +hello x y = annotateShow (x,y) $ + x + y + 42 +{-# OPAQUE hello #-} + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + print $ hello 2 3 + print $ tailCallEx 4 5 + +{-# INLINE tailCallEx #-} +tailCallEx :: Int -> Int -> Int +tailCallEx a b = annotateShow "tailCallEx" $ + foo a b + +{-# INLINE foo #-} +foo :: Int -> Int -> Int +foo a b = annotateShow "foo" $ + bar $ a * b + +bar c = annotateShow "bar" $ + error $ show $ c + c + ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ===================================== @@ -0,0 +1,36 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-} +import Control.Monad +import GHC.Stack.Types +import Control.Exception +import Control.Exception.Backtrace +import GHC.Stack.Annotation.Experimental + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + -- foo baz + bar + +foo :: HasCallStack => IO () -> IO () +foo act = annotateCallStackM $ do + putStrLn "Start some work" + act + putStrLn "Finish some work" + +baz :: HasCallStack => IO () +baz = annotateCallStackM $ do + print (fib 20) + throwIO $ ErrorCall "baz is interrupted" + +bar :: IO () +bar = annotateCallStackM $ annotateStringM "bar" $ do + putStrLn "Some more work in bar" + print (annotateCallStack $ fib 21) + +fib :: Int -> Int +fib n + | n <= 1 = 1 + | n >= 21 = throw $ ErrorCall "This fib implementation supports only up to the 21st fibonacci number" + | otherwise = fib (n - 1) + fib (n - 2) ===================================== libraries/ghc-internal/cbits/HeapPrim.cmm ===================================== @@ -0,0 +1,13 @@ +#include "Cmm.h" + +aToWordzh (P_ clos) +{ + return (clos); +} + +reallyUnsafePtrEqualityUpToTag (W_ clos1, W_ clos2) +{ + clos1 = UNTAG(clos1); + clos2 = UNTAG(clos2); + return (clos1 == clos2); +} ===================================== libraries/ghc-internal/cbits/Stack.cmm ===================================== @@ -0,0 +1,182 @@ +// Uncomment to enable assertions during development +// #define DEBUG 1 + +#include "Cmm.h" + +// StgStack_marking was not available in the Stage0 compiler at the time of +// writing. Because, it has been added to derivedConstants when Stack.cmm was +// developed. +#if defined(StgStack_marking) + +// Returns the next stackframe's StgStack* and offset in it. And, an indicator +// if this frame is the last one (`hasNext` bit.) +// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords) +advanceStackFrameLocationzh (P_ stack, W_ offsetWords) { + W_ frameSize; + (frameSize) = ccall stackFrameSize(stack, offsetWords); + + P_ nextClosurePtr; + nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize)); + + P_ stackArrayPtr; + stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack; + + P_ stackBottom; + W_ stackSize, stackSizeInBytes; + stackSize = TO_W_(StgStack_stack_size(stack)); + stackSizeInBytes = WDS(stackSize); + stackBottom = stackSizeInBytes + stackArrayPtr; + + P_ newStack; + W_ newOffsetWords, hasNext; + if(nextClosurePtr < stackBottom) (likely: True) { + newStack = stack; + newOffsetWords = offsetWords + frameSize; + hasNext = 1; + } else { + P_ underflowFrameStack; + (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords); + if (underflowFrameStack == NULL) (likely: True) { + newStack = NULL; + newOffsetWords = NULL; + hasNext = NULL; + } else { + newStack = underflowFrameStack; + newOffsetWords = NULL; + hasNext = 1; + } + } + + return (newStack, newOffsetWords, hasNext); +} + +// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords) +getSmallBitmapzh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ bitmap, size; + (bitmap) = ccall getBitmapWord(c); + (size) = ccall getBitmapSize(c); + + return (bitmap, size); +} + + +// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords) +getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ bitmap, size, specialType; + (bitmap) = ccall getRetFunBitmapWord(c); + (size) = ccall getRetFunBitmapSize(c); + + return (bitmap, size); +} + +// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getLargeBitmap(MyCapability(), c); + (size) = ccall getLargeBitmapSize(c); + + return (words, size); +} + +// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getBCOLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getBCOLargeBitmap(MyCapability(), c); + (size) = ccall getBCOLargeBitmapSize(c); + + return (words, size); +} + +// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getRetFunLargeBitmap(MyCapability(), c); + (size) = ccall getRetFunSize(c); + + return (words, size); +} + +// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords) +getWordzh(P_ stack, W_ offsetWords) { + P_ wordAddr; + wordAddr = (StgStack_sp(stack) + WDS(offsetWords)); + return (W_[wordAddr]); +} + +// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords) +getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) { + P_ closurePtr; + closurePtr = (StgStack_sp(stack) + WDS(offsetWords)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr)); + + P_ next_chunk; + (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk)); + return (next_chunk); +} + +// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords) +isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ type; + (type) = ccall isArgGenBigRetFunType(c); + return (type); +} + +// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrszh(P_ stack, W_ offsetWords) { + P_ p, info_struct, info_ptr; + p = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); + info_struct = %GET_STD_INFO(UNTAG(p)); + info_ptr = %INFO_PTR(UNTAG(p)); + return (info_struct, info_ptr); +} + +// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) +getStackInfoTableAddrzh(P_ stack) { + P_ info; + info = %GET_STD_INFO(UNTAG(stack)); + return (info); +} + +// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords) +getStackClosurezh(P_ stack, W_ offsetWords) { + P_ ptr; + ptr = StgStack_sp(stack) + WDS(offsetWords); + + P_ closure; + (closure) = ccall getStackClosure(ptr); + return (closure); +} + +// (bits32) getStackFieldszh(StgStack* stack) +getStackFieldszh(P_ stack){ + bits32 size; + size = StgStack_stack_size(stack); + return (size); +} +#endif ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -0,0 +1,151 @@ +#include "MachDeps.h" +#include "Rts.h" +#include "RtsAPI.h" +#include "rts/Messages.h" +#include "rts/Types.h" +#include "rts/storage/ClosureTypes.h" +#include "rts/storage/Closures.h" +#include "rts/storage/FunTypes.h" +#include "rts/storage/InfoTables.h" + +StgWord stackFrameSize(StgStack *stack, StgWord offset) { + StgClosure *c = (StgClosure *)stack->sp + offset; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + return stack_frame_sizeW(c); +} + +StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) { + StgClosure *frame = (StgClosure *)stack->sp + offset; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame)); + const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame); + + if (info->i.type == UNDERFLOW_FRAME) { + return ((StgUnderflowFrame *)frame)->next_chunk; + } else { + return NULL; + } +} + +// Only exists to make the get_itbl macro available in Haskell code (via FFI). +const StgInfoTable *getItbl(StgClosure *closure) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); + return get_itbl(closure); +}; + +StgWord getBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgWord bitmap = info->layout.bitmap; + return BITMAP_SIZE(bitmap); +} + +StgWord getRetFunBitmapSize(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_SIZE(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + return GET_FUN_LARGE_BITMAP(fun_info)->size; + default: + return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getBitmapWord(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgWord bitmap = info->layout.bitmap; + StgWord bitmapWord = BITMAP_BITS(bitmap); + return bitmapWord; +} + +StgWord getRetFunBitmapWord(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_BITS(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + // Cannot do more than warn and exit. + errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun); + stg_exit(EXIT_INTERNAL_ERROR); + default: + return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getLargeBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + return bitmap->size; +} + +StgWord getRetFunSize(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_SIZE(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + return GET_FUN_LARGE_BITMAP(fun_info)->size; + default: + return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getBCOLargeBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + StgBCO *bco = (StgBCO *)*c->payload; + + return BCO_BITMAP_SIZE(bco); +} + +StgWord *getLargeBitmap(Capability *cap, StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + const StgInfoTable *info = get_itbl(c); + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + + return bitmap->bitmap; +} + +StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info); + + return bitmap->bitmap; +} + +StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + StgBCO *bco = (StgBCO *)*c->payload; + StgLargeBitmap *bitmap = BCO_BITMAP(bco); + + return bitmap->bitmap; +} + +StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) { + return frame->next_chunk; +} + +StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + return fun_info->f.fun_type == ARG_GEN_BIG; +} + +StgClosure *getStackClosure(StgClosure **c) { return *c; } ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -231,6 +231,12 @@ Library GHC.Internal.GHCi GHC.Internal.GHCi.Helpers GHC.Internal.Generics + GHC.Internal.Heap.Closures + GHC.Internal.Heap.Constants + GHC.Internal.Heap.InfoTable + GHC.Internal.Heap.InfoTable.Types + GHC.Internal.Heap.InfoTableProf + GHC.Internal.Heap.ProfInfo.Types GHC.Internal.InfoProv GHC.Internal.InfoProv.Types GHC.Internal.IO @@ -283,14 +289,17 @@ Library GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST - GHC.Internal.Stack.CloneStack GHC.Internal.StaticPtr GHC.Internal.STRef GHC.Internal.Show GHC.Internal.Stable GHC.Internal.StableName GHC.Internal.Stack + GHC.Internal.Stack.Annotation GHC.Internal.Stack.CCS + GHC.Internal.Stack.CloneStack + GHC.Internal.Stack.Constants + GHC.Internal.Stack.Decode GHC.Internal.Stack.Types GHC.Internal.Stats GHC.Internal.Storable @@ -449,9 +458,12 @@ Library cbits/popcnt.c cbits/vectorQuotRem.c cbits/word2float.c + cbits/Stack_c.c cmm-sources: cbits/StackCloningDecoding.cmm + cbits/Stack.cmm + cbits/HeapPrim.cmm if arch(javascript) js-sources: ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -7,6 +7,8 @@ module GHC.Internal.Exception.Backtrace where import GHC.Internal.Base import GHC.Internal.Data.OldList +import GHC.Internal.Data.Functor +import GHC.Internal.Data.Maybe import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context @@ -16,6 +18,7 @@ import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack as ExecStack import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack +import qualified GHC.Internal.Stack.Decode as Decode import qualified GHC.Internal.Stack.CCS as CCS -- | How to collect a backtrace when an exception is thrown. @@ -37,6 +40,14 @@ data EnabledBacktraceMechanisms = , ipeBacktraceEnabled :: !Bool } +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: [ExecStack.Location] -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms { costCentreBacktraceEnabled = False @@ -45,6 +56,19 @@ defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms , ipeBacktraceEnabled = False } +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms + { displayCostCentreBacktrace = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings + , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack + , displayExecutionBacktrace = unlines . map (indent 2 . flip ExecStack.showLocation "") + , displayIpeBacktrace = unlines . mapMaybe (fmap (indent 2) . Decode.prettyStackFrameWithIpe) . unsafePerformIO . Decode.decodeStackWithIpe + } + where + indent :: Int -> String -> String + indent n s = replicate n ' ' ++ s + + prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc + backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool backtraceMechanismEnabled bm = case bm of @@ -69,6 +93,11 @@ enabledBacktraceMechanismsRef = unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms {-# NOINLINE enabledBacktraceMechanismsRef #-} +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + -- | Returns the currently enabled 'BacktraceMechanism's. getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanismsRef @@ -86,37 +115,41 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () +-- TODO @fendor +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- TODO @fendor: +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + -- | A collection of backtraces. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, + btrDisplayHasCallStack :: HCS.CallStack -> String, btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayExecutionStack :: [ExecStack.Location] -> String, + btrIpe :: Maybe CloneStack.StackSnapshot, + btrDisplayIpe :: CloneStack.StackSnapshot -> String } -- | Render a set of backtraces to a human-readable string. displayBacktraces :: Backtraces -> String displayBacktraces bts = concat - [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc - , displayOne "Native stack backtrace" btrExecutionStack displayExec - , displayOne "IPE backtrace" btrIpe displayIpe - , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc + [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre + , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack + , displayOne "IPE backtrace" btrIpe btrDisplayIpe + , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack ] where - indent :: Int -> String -> String - indent n s = replicate n ' ' ++ s - - -- The unsafePerformIO here is safe as we don't currently unload cost-centres. - displayCc = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings - displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) - displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack - where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc - - displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String + displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String displayOne label getBt displ - | Just bt <- getBt bts = concat [label, ":\n", displ bt] + | Just bt <- getBt bts = concat [label, ":\n", displ bts bt] | otherwise = "" instance ExceptionAnnotation Backtraces where @@ -125,12 +158,14 @@ instance ExceptionAnnotation Backtraces where -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do - getEnabledBacktraceMechanisms >>= collectBacktraces' + bm <- getEnabledBacktraceMechanisms + dpm <- getDisplayBacktraceMechanisms + collectBacktraces' bm dpm collectBacktraces' :: (?callStack :: CallStack) - => EnabledBacktraceMechanisms -> IO Backtraces -collectBacktraces' enabled = HCS.withFrozenCallStack $ do + => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a) collect mech f | backtraceMechanismEnabled mech enabled = f @@ -144,14 +179,17 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do ipe <- collect IPEBacktrace $ do stack <- CloneStack.cloneMyStack - stackEntries <- CloneStack.decode stack - return (Just stackEntries) + return (Just stack) hcs <- collect HasCallStackBacktrace $ do return (Just ?callStack) return (Backtraces { btrCostCentre = ccs + , btrDisplayCostCentre = displayCostCentreBacktrace renderers , btrHasCallStack = hcs + , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers , btrExecutionStack = exec + , btrDisplayExecutionStack = displayExecutionBacktrace renderers , btrIpe = ipe + , btrDisplayIpe = displayIpeBacktrace renderers }) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs ===================================== @@ -0,0 +1,669 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +-- Late cost centres introduce a thunk in the asBox function, which leads to +-- an additional wrapper being added to any value placed inside a box. +-- This can be removed once our boot compiler is no longer affected by #25212 +{-# OPTIONS_GHC -fno-prof-late #-} +{-# LANGUAGE NamedFieldPuns #-} + +module GHC.Internal.Heap.Closures ( + -- * Closures + Closure + , GenClosure(..) + , getClosureInfoTbl + , getClosureInfoTbl_maybe + , getClosurePtrArgs + , getClosurePtrArgs_maybe + , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) + , allClosures + , closureSize + + -- * Stack + , StgStackClosure + , GenStgStackClosure(..) + , StackFrame + , GenStackFrame(..) + , StackField + , GenStackField(..) + + -- * Boxes + , Box(..) + , areBoxesEqual + , asBox + ) where + +import GHC.Internal.Base +import GHC.Internal.Show + +import GHC.Internal.Heap.Constants +#if defined(PROFILING) +import GHC.Internal.Heap.InfoTable () -- see Note [No way-dependent imports] +import GHC.Internal.Heap.InfoTableProf +#else +import GHC.Internal.Heap.InfoTable +import GHC.Internal.Heap.InfoTableProf () -- see Note [No way-dependent imports] + +{- +Note [No way-dependent imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`ghc -M` currently assumes that the imports for a module are the same +in every way. This is arguably a bug, but breaking this assumption by +importing different things in different ways can cause trouble. For +example, this module in the profiling way imports and uses +GHC.Exts.Heap.InfoTableProf. When it was not also imported in the +vanilla way, there were intermittent build failures due to this module +being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf +in the profiling way. (#15197) +-} +#endif + +import GHC.Internal.Heap.ProfInfo.Types + +import GHC.Internal.Data.Bits +import GHC.Internal.Data.Foldable (Foldable, toList) +import GHC.Internal.Data.Traversable (Traversable) +import GHC.Internal.Int +import GHC.Internal.Num +import GHC.Internal.Real +import GHC.Internal.Word +import GHC.Internal.Exts +import GHC.Internal.Generics +import GHC.Internal.Numeric +import GHC.Internal.Stack (HasCallStack) + +------------------------------------------------------------------------ +-- Boxes + +foreign import prim "aToWordzh" aToWord# :: Any -> Word# + +foreign import prim "reallyUnsafePtrEqualityUpToTag" + reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int# + +-- | An arbitrary Haskell value in a safe Box. The point is that even +-- unevaluated thunks can safely be moved around inside the Box, and when +-- required, e.g. in 'getBoxedClosureData', the function knows how far it has +-- to evaluate the argument. +data Box = Box Any + +instance Show Box where +-- From libraries/base/GHC/Ptr.lhs + showsPrec _ (Box a) rs = + -- unsafePerformIO (print "↓" >> pClosure a) `seq` + pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs + where + ptr = W# (aToWord# a) + tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) + addr = ptr - tag + pad_out ls = '0':'x':ls + +-- |This takes an arbitrary value and puts it into a box. +-- Note that calls like +-- +-- > asBox (head list) +-- +-- will put the thunk \"head list\" into the box, /not/ the element at the head +-- of the list. For that, use careful case expressions: +-- +-- > case list of x:_ -> asBox x +asBox :: a -> Box +asBox x = Box (unsafeCoerce# x) + +-- | Boxes can be compared, but this is not pure, as different heap objects can, +-- after garbage collection, become the same object. +areBoxesEqual :: Box -> Box -> IO Bool +areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of + 0# -> pure False + _ -> pure True + + +------------------------------------------------------------------------ +-- Closures +type Closure = GenClosure Box + +-- | This is the representation of a Haskell value on the heap. It reflects +-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closu... +-- +-- The data type is parametrized by `b`: the type to store references in. +-- Usually this is a 'Box' with the type synonym 'Closure'. +-- +-- All Heap objects have the same basic layout. A header containing a pointer to +-- the info table and a payload with various fields. The @info@ field below +-- always refers to the info table pointed to by the header. The remaining +-- fields are the payload. +-- +-- See +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects +-- for more information. +data GenClosure b + = -- | A data constructor + ConstrClosure + { info :: !StgInfoTable + , ptrArgs :: ![b] -- ^ Pointer arguments + , dataArgs :: ![Word] -- ^ Non-pointer arguments + , pkg :: !String -- ^ Package name + , modl :: !String -- ^ Module name + , name :: !String -- ^ Constructor name + } + + -- | A function + | FunClosure + { info :: !StgInfoTable + , ptrArgs :: ![b] -- ^ Pointer arguments + , dataArgs :: ![Word] -- ^ Non-pointer arguments + } + + -- | A thunk, an expression not obviously in head normal form + | ThunkClosure + { info :: !StgInfoTable + , ptrArgs :: ![b] -- ^ Pointer arguments + , dataArgs :: ![Word] -- ^ Non-pointer arguments + } + + -- | A thunk which performs a simple selection operation + | SelectorClosure + { info :: !StgInfoTable + , selectee :: !b -- ^ Pointer to the object being + -- selected from + } + + -- | An unsaturated function application + | PAPClosure + { info :: !StgInfoTable + , arity :: !HalfWord -- ^ Arity of the partial application + , n_args :: !HalfWord -- ^ Size of the payload in words + , fun :: !b -- ^ Pointer to a 'FunClosure' + , payload :: ![b] -- ^ Sequence of already applied + -- arguments + } + + -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported + -- functions fun actually find the name here. + -- At least the other direction works via "lookupSymbol + -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags) + -- | A function application + | APClosure + { info :: !StgInfoTable + , arity :: !HalfWord -- ^ Always 0 + , n_args :: !HalfWord -- ^ Size of payload in words + , fun :: !b -- ^ Pointer to a 'FunClosure' + , payload :: ![b] -- ^ Sequence of already applied + -- arguments + } + + -- | A suspended thunk evaluation + | APStackClosure + { info :: !StgInfoTable + , fun :: !b -- ^ Function closure + , payload :: ![b] -- ^ Stack right before suspension + } + + -- | A pointer to another closure, introduced when a thunk is updated + -- to point at its value + | IndClosure + { info :: !StgInfoTable + , indirectee :: !b -- ^ Target closure + } + + -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code + -- interpreter (e.g. as used by GHCi) + | BCOClosure + { info :: !StgInfoTable + , instrs :: !b -- ^ A pointer to an ArrWords + -- of instructions + , literals :: !b -- ^ A pointer to an ArrWords + -- of literals + , bcoptrs :: !b -- ^ A pointer to an ArrWords + -- of byte code objects + , arity :: !HalfWord -- ^ The arity of this BCO + , size :: !HalfWord -- ^ The size of this BCO in words + , bitmap :: ![Word] -- ^ An StgLargeBitmap describing the + -- pointerhood of its args/free vars + } + + -- | A thunk under evaluation by another thread + | BlackholeClosure + { info :: !StgInfoTable + , indirectee :: !b -- ^ The target closure + } + + -- | A @ByteArray#@ + | ArrWordsClosure + { info :: !StgInfoTable + , bytes :: !Word -- ^ Size of array in bytes + , arrWords :: ![Word] -- ^ Array payload + } + + -- | A @MutableByteArray#@ + | MutArrClosure + { info :: !StgInfoTable + , mccPtrs :: !Word -- ^ Number of pointers + , mccSize :: !Word -- ^ ?? Closures.h vs ClosureMacros.h + , mccPayload :: ![b] -- ^ Array payload + -- Card table ignored + } + + -- | A @SmallMutableArray#@ + -- + -- @since 8.10.1 + | SmallMutArrClosure + { info :: !StgInfoTable + , mccPtrs :: !Word -- ^ Number of pointers + , mccPayload :: ![b] -- ^ Array payload + } + + -- | An @MVar#@, with a queue of thread state objects blocking on them + | MVarClosure + { info :: !StgInfoTable + , queueHead :: !b -- ^ Pointer to head of queue + , queueTail :: !b -- ^ Pointer to tail of queue + , value :: !b -- ^ Pointer to closure + } + + -- | An @IOPort#@, with a queue of thread state objects blocking on them + | IOPortClosure + { info :: !StgInfoTable + , queueHead :: !b -- ^ Pointer to head of queue + , queueTail :: !b -- ^ Pointer to tail of queue + , value :: !b -- ^ Pointer to closure + } + + -- | A @MutVar#@ + | MutVarClosure + { info :: !StgInfoTable + , var :: !b -- ^ Pointer to contents + } + + -- | An STM blocking queue. + | BlockingQueueClosure + { info :: !StgInfoTable + , link :: !b -- ^ ?? Here so it looks like an IND + , blackHole :: !b -- ^ The blackhole closure + , owner :: !b -- ^ The owning thread state object + , queue :: !b -- ^ ?? + } + + | WeakClosure + { info :: !StgInfoTable + , cfinalizers :: !b + , key :: !b + , value :: !b + , finalizer :: !b + , weakLink :: !(Maybe b) -- ^ next weak pointer for the capability + } + + -- | Representation of StgTSO: A Thread State Object. The values for + -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@. + | TSOClosure + { info :: !StgInfoTable + -- pointers + , link :: !b + , global_link :: !b + , tsoStack :: !b -- ^ stackobj from StgTSO + , trec :: !b + , blocked_exceptions :: !b + , bq :: !b + , thread_label :: !(Maybe b) + -- values + , what_next :: !WhatNext + , why_blocked :: !WhyBlocked + , flags :: ![TsoFlags] + , threadId :: !Word64 + , saved_errno :: !Word32 + , tso_dirty :: !Word32 -- ^ non-zero => dirty + , alloc_limit :: !Int64 + , tot_stack_size :: !Word32 + , prof :: !(Maybe StgTSOProfInfo) + } + + -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'. + | StackClosure + { info :: !StgInfoTable + , stack_size :: !Word32 -- ^ stack size in *words* + , stack_dirty :: !Word8 -- ^ non-zero => dirty + , stack_marking :: !Word8 + } + + ------------------------------------------------------------ + -- Unboxed unlifted closures + + -- | Primitive Int + | IntClosure + { ptipe :: PrimType + , intVal :: !Int } + + -- | Primitive Word + | WordClosure + { ptipe :: PrimType + , wordVal :: !Word } + + -- | Primitive Int64 + | Int64Closure + { ptipe :: PrimType + , int64Val :: !Int64 } + + -- | Primitive Word64 + | Word64Closure + { ptipe :: PrimType + , word64Val :: !Word64 } + + -- | Primitive Addr + | AddrClosure + { ptipe :: PrimType + , addrVal :: !(Ptr ()) } + + -- | Primitive Float + | FloatClosure + { ptipe :: PrimType + , floatVal :: !Float } + + -- | Primitive Double + | DoubleClosure + { ptipe :: PrimType + , doubleVal :: !Double } + + ----------------------------------------------------------- + -- Anything else + + -- | Another kind of closure + | OtherClosure + { info :: !StgInfoTable + , hvalues :: ![b] + , rawWords :: ![Word] + } + + | UnsupportedClosure + { info :: !StgInfoTable + } + + -- | A primitive word from a bitmap encoded stack frame payload + -- + -- The type itself cannot be restored (i.e. it might represent a Word8# + -- or an Int#). + | UnknownTypeWordSizedPrimitive + { wordVal :: !Word } + deriving (Show, Generic, Functor, Foldable, Traversable) + +-- | Get the info table for a heap closure, or Nothing for a prim value +-- +-- @since 9.14.1 +getClosureInfoTbl_maybe :: GenClosure b -> Maybe StgInfoTable +{-# INLINE getClosureInfoTbl_maybe #-} -- Ensure we can get rid of the just box +getClosureInfoTbl_maybe closure = case closure of + ConstrClosure{info} ->Just info + FunClosure{info} ->Just info + ThunkClosure{info} ->Just info + SelectorClosure{info} ->Just info + PAPClosure{info} ->Just info + APClosure{info} ->Just info + APStackClosure{info} ->Just info + IndClosure{info} ->Just info + BCOClosure{info} ->Just info + BlackholeClosure{info} ->Just info + ArrWordsClosure{info} ->Just info + MutArrClosure{info} ->Just info + SmallMutArrClosure{info} ->Just info + MVarClosure{info} ->Just info + IOPortClosure{info} ->Just info + MutVarClosure{info} ->Just info + BlockingQueueClosure{info} ->Just info + WeakClosure{info} ->Just info + TSOClosure{info} ->Just info + StackClosure{info} ->Just info + + IntClosure{} -> Nothing + WordClosure{} -> Nothing + Int64Closure{} -> Nothing + Word64Closure{} -> Nothing + AddrClosure{} -> Nothing + FloatClosure{} -> Nothing + DoubleClosure{} -> Nothing + + OtherClosure{info} -> Just info + UnsupportedClosure {info} -> Just info + + UnknownTypeWordSizedPrimitive{} -> Nothing + +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a +-- heap closure. +-- +-- @since 9.14.1 +getClosureInfoTbl :: HasCallStack => GenClosure b -> StgInfoTable +getClosureInfoTbl closure = case getClosureInfoTbl_maybe closure of + Just info -> info + Nothing -> error "getClosureInfoTbl - Closure without info table" + +-- | Get the info table for a heap closure, or Nothing for a prim value +-- +-- @since 9.14.1 +getClosurePtrArgs_maybe :: GenClosure b -> Maybe [b] +{-# INLINE getClosurePtrArgs_maybe #-} -- Ensure we can get rid of the just box +getClosurePtrArgs_maybe closure = case closure of + ConstrClosure{ptrArgs} -> Just ptrArgs + FunClosure{ptrArgs} -> Just ptrArgs + ThunkClosure{ptrArgs} -> Just ptrArgs + SelectorClosure{} -> Nothing + PAPClosure{} -> Nothing + APClosure{} -> Nothing + APStackClosure{} -> Nothing + IndClosure{} -> Nothing + BCOClosure{} -> Nothing + BlackholeClosure{} -> Nothing + ArrWordsClosure{} -> Nothing + MutArrClosure{} -> Nothing + SmallMutArrClosure{} -> Nothing + MVarClosure{} -> Nothing + IOPortClosure{} -> Nothing + MutVarClosure{} -> Nothing + BlockingQueueClosure{} -> Nothing + WeakClosure{} -> Nothing + TSOClosure{} -> Nothing + StackClosure{} -> Nothing + + IntClosure{} -> Nothing + WordClosure{} -> Nothing + Int64Closure{} -> Nothing + Word64Closure{} -> Nothing + AddrClosure{} -> Nothing + FloatClosure{} -> Nothing + DoubleClosure{} -> Nothing + + OtherClosure{} -> Nothing + UnsupportedClosure{} -> Nothing + + UnknownTypeWordSizedPrimitive{} -> Nothing + +-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a +-- heap closure. +-- +-- @since 9.14.1 +getClosurePtrArgs :: HasCallStack => GenClosure b -> [b] +getClosurePtrArgs closure = case getClosurePtrArgs_maybe closure of + Just ptrs -> ptrs + Nothing -> error "getClosurePtrArgs - Closure without ptrArgs field" + +type StgStackClosure = GenStgStackClosure Box + +-- | A decoded @StgStack@ with `StackFrame`s +-- +-- Stack related data structures (`GenStgStackClosure`, `GenStackField`, +-- `GenStackFrame`) are defined separately from `GenClosure` as their related +-- functions are very different. Though, both are closures in the sense of RTS +-- structures, their decoding logic differs: While it's safe to keep a reference +-- to a heap closure, the garbage collector does not update references to stack +-- located closures. +-- +-- Additionally, stack frames don't appear outside of the stack. Thus, keeping +-- `GenStackFrame` and `GenClosure` separated, makes these types more precise +-- (in the sense what values to expect.) +data GenStgStackClosure b = GenStgStackClosure + { ssc_info :: !StgInfoTable + , ssc_stack_size :: !Word32 -- ^ stack size in *words* + , ssc_stack :: ![GenStackFrame b] + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackField = GenStackField Box + +-- | Bitmap-encoded payload on the stack +data GenStackField b + -- | A non-pointer field + = StackWord !Word + -- | A pointer field + | StackBox !b + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackFrame = GenStackFrame Box + +-- | A single stack frame +data GenStackFrame b = + UpdateFrame + { info_tbl :: !StgInfoTable + , updatee :: !b + } + + | CatchFrame + { info_tbl :: !StgInfoTable + , handler :: !b + } + + | CatchStmFrame + { info_tbl :: !StgInfoTable + , catchFrameCode :: !b + , handler :: !b + } + + | CatchRetryFrame + { info_tbl :: !StgInfoTable + , running_alt_code :: !Word + , first_code :: !b + , alt_code :: !b + } + + | AtomicallyFrame + { info_tbl :: !StgInfoTable + , atomicallyFrameCode :: !b + , result :: !b + } + + | UnderflowFrame + { info_tbl :: !StgInfoTable + , nextChunk :: !(GenStgStackClosure b) + } + + | StopFrame + { info_tbl :: !StgInfoTable } + + | RetSmall + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetBig + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetFun + { info_tbl :: !StgInfoTable + , retFunSize :: !Word + , retFunFun :: !b + , retFunPayload :: ![GenStackField b] + } + + | RetBCO + { info_tbl :: !StgInfoTable + , bco :: !b -- ^ always a BCOClosure + , bcoArgs :: ![GenStackField b] + } + | AnnFrame + { info_tbl :: !StgInfoTable + , annotation :: !b + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +data PrimType + = PInt + | PWord + | PInt64 + | PWord64 + | PAddr + | PFloat + | PDouble + deriving (Eq, Show, Generic, Ord) + +data WhatNext + = ThreadRunGHC + | ThreadInterpret + | ThreadKilled + | ThreadComplete + | WhatNextUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +data WhyBlocked + = NotBlocked + | BlockedOnMVar + | BlockedOnMVarRead + | BlockedOnBlackHole + | BlockedOnRead + | BlockedOnWrite + | BlockedOnDelay + | BlockedOnSTM + | BlockedOnDoProc + | BlockedOnCCall + | BlockedOnCCall_Interruptible + | BlockedOnMsgThrowTo + | ThreadMigrating + | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +data TsoFlags + = TsoLocked + | TsoBlockx + | TsoInterruptible + | TsoStoppedOnBreakpoint + | TsoMarked + | TsoSqueezed + | TsoAllocLimit + | TsoStopNextBreakpoint + | TsoStopAfterReturn + | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +-- | For generic code, this function returns all referenced closures. +allClosures :: GenClosure b -> [b] +allClosures (ConstrClosure {..}) = ptrArgs +allClosures (ThunkClosure {..}) = ptrArgs +allClosures (SelectorClosure {..}) = [selectee] +allClosures (IndClosure {..}) = [indirectee] +allClosures (BlackholeClosure {..}) = [indirectee] +allClosures (APClosure {..}) = fun:payload +allClosures (PAPClosure {..}) = fun:payload +allClosures (APStackClosure {..}) = fun:payload +allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs] +allClosures (ArrWordsClosure {}) = [] +allClosures (MutArrClosure {..}) = mccPayload +allClosures (SmallMutArrClosure {..}) = mccPayload +allClosures (MutVarClosure {..}) = [var] +allClosures (MVarClosure {..}) = [queueHead,queueTail,value] +allClosures (IOPortClosure {..}) = [queueHead,queueTail,value] +allClosures (FunClosure {..}) = ptrArgs +allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] +allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ GHC.Internal.Data.Foldable.toList weakLink +allClosures (OtherClosure {..}) = hvalues +allClosures _ = [] + +-- | Get the size of the top-level closure in words. +-- Includes header and payload. Does not follow pointers. +-- +-- @since 8.10.1 +closureSize :: Box -> Int +closureSize (Box x) = I# (closureSize# x) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} + +module GHC.Internal.Heap.Constants + ( wORD_SIZE + , tAG_MASK + , wORD_SIZE_IN_BITS + ) where + +#include "MachDeps.h" + +import GHC.Internal.Data.Bits +import GHC.Internal.Int +import GHC.Internal.Num + +wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int +wORD_SIZE = #const SIZEOF_HSWORD +wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS +tAG_MASK = (1 `shift` #const TAG_BITS) - 1 ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc ===================================== @@ -0,0 +1,79 @@ +module GHC.Internal.Heap.InfoTable + ( module GHC.Internal.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +#include "Rts.h" + +import GHC.Internal.Base +import GHC.Internal.Data.Either +import GHC.Internal.Real +import GHC.Internal.Enum + +import GHC.Internal.Heap.InfoTable.Types +#if !defined(TABLES_NEXT_TO_CODE) +import GHC.Internal.Heap.Constants +import GHC.Internal.Data.Maybe +#endif +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Foreign.Marshal.Array + +------------------------------------------------------------------------- +-- Profiling specific code +-- +-- The functions that follow all rely on PROFILING. They are duplicated in +-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This +-- allows hsc2hs to generate values for both profiling and non-profiling builds. + +-- | Read an InfoTable from the heap into a haskell type. +-- WARNING: This code assumes it is passed a pointer to a "standard" info +-- table. If tables_next_to_code is disabled, it will look 1 word before the +-- start for the entry field. +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if !defined(TABLES_NEXT_TO_CODE) + let ptr = a0 `plusPtr` (negate wORD_SIZE) + entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr +#else + let ptr = a0 + entry' = Nothing +#endif + ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr + nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr + tipe' <- (#peek struct StgInfoTable_, type) ptr + srtlen' <- (#peek struct StgInfoTable_, srt) a0 + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) + , srtlen = srtlen' + , code = Nothing + } + +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl a0 itbl = do +#if !defined(TABLES_NEXT_TO_CODE) + (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) +#endif + (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) + (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) + (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl))) + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#if defined(TABLES_NEXT_TO_CODE) + let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) + case code itbl of + Nothing -> return () + Just (Left xs) -> pokeArray code_offset xs + Just (Right xs) -> pokeArray code_offset xs +#endif + where + toHalfWord :: Int -> HalfWord + toHalfWord i = fromIntegral i + +-- | Size in bytes of a standard InfoTable +itblSize :: Int +itblSize = (#size struct StgInfoTable_) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc ===================================== @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Internal.Heap.InfoTable.Types + ( StgInfoTable(..) + , EntryFunPtr + , HalfWord(..) + , ItblCodes + ) where + +#include "Rts.h" + +import GHC.Internal.Base +import GHC.Internal.Generics +import GHC.Internal.ClosureTypes +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Word +import GHC.Internal.Show +import GHC.Internal.Real +import GHC.Internal.Data.Either + +type ItblCodes = Either [Word8] [Word32] + +#include "ghcautoconf.h" +-- Ultra-minimalist version specially for constructors +#if SIZEOF_VOID_P == 8 +type HalfWord' = Word32 +#elif SIZEOF_VOID_P == 4 +type HalfWord' = Word16 +#else +#error Unknown SIZEOF_VOID_P +#endif + +newtype HalfWord = HalfWord HalfWord' + deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable) + +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) + +-- | This is a somewhat faithful representation of an info table. See +-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoT... +-- for more details on this data structure. +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: ClosureType, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE + } deriving (Eq, Show, Generic) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc ===================================== @@ -0,0 +1,72 @@ +module GHC.Internal.Heap.InfoTableProf + ( module GHC.Internal.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl. +-- Manually defining PROFILING gives the #peek and #poke macros an accurate +-- representation of StgInfoTable_ when hsc2hs runs. +#define PROFILING +#include "Rts.h" + +import GHC.Internal.Base +import GHC.Internal.Data.Either +import GHC.Internal.Real +import GHC.Internal.Enum + +import GHC.Internal.Heap.InfoTable.Types +#if !defined(TABLES_NEXT_TO_CODE) +import GHC.Internal.Heap.Constants +import GHC.Internal.Data.Maybe +#endif +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Foreign.Marshal.Array + +-- | Read an InfoTable from the heap into a haskell type. +-- WARNING: This code assumes it is passed a pointer to a "standard" info +-- table. If tables_next_to_code is enabled, it will look 1 byte before the +-- start for the entry field. +peekItbl :: Ptr StgInfoTable -> IO StgInfoTable +peekItbl a0 = do +#if !defined(TABLES_NEXT_TO_CODE) + let ptr = a0 `plusPtr` (negate wORD_SIZE) + entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr +#else + let ptr = a0 + entry' = Nothing +#endif + ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr + nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr + tipe' <- (#peek struct StgInfoTable_, type) ptr + srtlen' <- (#peek struct StgInfoTable_, srt) a0 + return StgInfoTable + { entry = entry' + , ptrs = ptrs' + , nptrs = nptrs' + , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) + , srtlen = srtlen' + , code = Nothing + } + +pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl a0 itbl = do +#if !defined(TABLES_NEXT_TO_CODE) + (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) +#endif + (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) + (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) + (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl)) + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#if defined(TABLES_NEXT_TO_CODE) + let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) + case code itbl of + Nothing -> return () + Just (Left xs) -> pokeArray code_offset xs + Just (Right xs) -> pokeArray code_offset xs +#endif + +itblSize :: Int +itblSize = (#size struct StgInfoTable_) ===================================== libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs ===================================== @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveGeneric #-} + +module GHC.Internal.Heap.ProfInfo.Types where + +import GHC.Internal.Base +import GHC.Internal.Word +import GHC.Internal.Generics +import GHC.Internal.Show + +-- | This is a somewhat faithful representation of StgTSOProfInfo. See +-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h +-- for more details on this data structure. +newtype StgTSOProfInfo = StgTSOProfInfo { + cccs :: Maybe CostCentreStack +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of CostCentreStack. See +-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h +-- for more details on this data structure. +data CostCentreStack = CostCentreStack { + ccs_ccsID :: Int, + ccs_cc :: CostCentre, + ccs_prevStack :: Maybe CostCentreStack, + ccs_indexTable :: Maybe IndexTable, + ccs_root :: Maybe CostCentreStack, + ccs_depth :: Word, + ccs_scc_count :: Word64, + ccs_selected :: Word, + ccs_time_ticks :: Word, + ccs_mem_alloc :: Word64, + ccs_inherited_alloc :: Word64, + ccs_inherited_ticks :: Word +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of CostCentre. See +-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h +-- for more details on this data structure. +data CostCentre = CostCentre { + cc_ccID :: Int, + cc_label :: String, + cc_module :: String, + cc_srcloc :: Maybe String, + cc_mem_alloc :: Word64, + cc_time_ticks :: Word, + cc_is_caf :: Bool, + cc_link :: Maybe CostCentre +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of IndexTable. See +-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h +-- for more details on this data structure. +data IndexTable = IndexTable { + it_cc :: CostCentre, + it_ccs :: Maybe CostCentreStack, + it_next :: Maybe IndexTable, + it_back_edge :: Bool +} deriving (Show, Generic, Eq, Ord) ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs ===================================== @@ -0,0 +1,32 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Internal.Stack.Annotation ( + IsStackAnnotation(..), + SomeStackAnnotation(..), + ) + where + +import GHC.Internal.Base +import GHC.Internal.Data.Typeable + +-- ---------------------------------------------------------------------------- +-- IsStackAnnotation +-- ---------------------------------------------------------------------------- + +class IsStackAnnotation a where + displayStackAnnotation :: a -> String + +-- ---------------------------------------------------------------------------- +-- Annotations +-- ---------------------------------------------------------------------------- + +{- | +The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy. +When the call stack is annotated with a value of type @a@, behind the scenes it is +encapsulated in a @SomeStackAnnotation@. +-} +data SomeStackAnnotation where + SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation + +instance IsStackAnnotation SomeStackAnnotation where + displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs ===================================== @@ -18,8 +18,8 @@ module GHC.Internal.Stack.CloneStack ( StackEntry(..), cloneMyStack, cloneThreadStack, - decode, - prettyStackEntry + decode, -- TODO @fendor: deprecate + toStackEntry, -- TODO @fendor: deprecate ) where import GHC.Internal.MVar @@ -40,7 +40,7 @@ import GHC.Internal.ClosureTypes -- -- @since base-4.17.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# - +-- TODO @fendor: deprecate foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #) foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) @@ -208,6 +208,7 @@ cloneThreadStack (ThreadId tid#) = do -- | Representation for the source location where a return frame was pushed on the stack. -- This happens every time when a @case ... of@ scrutinee is evaluated. +-- TODO @fendor: deprecate data StackEntry = StackEntry { functionName :: String, moduleName :: String, @@ -232,9 +233,11 @@ data StackEntry = StackEntry -- is evaluated.) -- -- @since base-4.17.0.0 +-- TODO @fendor: deprecate decode :: StackSnapshot -> IO [StackEntry] decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot +-- TODO @fendor: deprecate toStackEntry :: InfoProv -> StackEntry toStackEntry infoProv = StackEntry @@ -244,6 +247,7 @@ toStackEntry infoProv = closureType = ipDesc infoProv } +-- TODO @fendor: deprecate getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry] getDecodedStackArray (StackSnapshot s) = IO $ \s0 -> case decodeStack# s s0 of @@ -263,6 +267,7 @@ getDecodedStackArray (StackSnapshot s) = wordSize = sizeOf (nullPtr :: Ptr ()) +-- TODO @fendor: deprecate prettyStackEntry :: StackEntry -> String prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = " " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc ===================================== @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Internal.Stack.Constants where + +import GHC.Internal.Base +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Show +import GHC.Internal.Real + +#include "Rts.h" +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#undef BLOCKS_PER_MBLOCK +#include "DerivedConstants.h" + +newtype ByteOffset = ByteOffset { offsetInBytes :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +newtype WordOffset = WordOffset { offsetInWords :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +offsetStgCatchFrameHandler :: WordOffset +offsetStgCatchFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader) + +sizeStgCatchFrame :: Int +sizeStgCatchFrame = bytesToWords $ + (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchSTMFrameCode :: WordOffset +offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader) + +offsetStgCatchSTMFrameHandler :: WordOffset +offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader) + +sizeStgCatchSTMFrame :: Int +sizeStgCatchSTMFrame = bytesToWords $ + (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader) + +offsetStgUpdateFrameUpdatee :: WordOffset +offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ + (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader) + +sizeStgUpdateFrame :: Int +sizeStgUpdateFrame = bytesToWords $ + (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader) + +offsetStgAtomicallyFrameCode :: WordOffset +offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader) + +offsetStgAtomicallyFrameResult :: WordOffset +offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader) + +sizeStgAtomicallyFrame :: Int +sizeStgAtomicallyFrame = bytesToWords $ + (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningAltCode :: WordOffset +offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningFirstCode :: WordOffset +offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader) + +offsetStgCatchRetryFrameAltCode :: WordOffset +offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader) + +sizeStgCatchRetryFrame :: Int +sizeStgCatchRetryFrame = bytesToWords $ + (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader) + +offsetStgRetFunFrameSize :: WordOffset +-- StgRetFun has no header, but only a pointer to the info table at the beginning. +offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size) + +offsetStgRetFunFrameFun :: WordOffset +offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun) + +offsetStgRetFunFramePayload :: WordOffset +offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload) + +sizeStgRetFunFrame :: Int +sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun) + +sizeStgAnnFrame :: Int +sizeStgAnnFrame = bytesToWords $ + (#const SIZEOF_StgAnnFrame_NoHdr) + (#size StgHeader) + +offsetStgAnnFrameAnn :: WordOffset +offsetStgAnnFrameAnn = byteOffsetToWordOffset $ + (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader) + +offsetStgBCOFrameInstrs :: ByteOffset +offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader) + +offsetStgBCOFrameLiterals :: ByteOffset +offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader) + +offsetStgBCOFramePtrs :: ByteOffset +offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader) + +offsetStgBCOFrameArity :: ByteOffset +offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader) + +offsetStgBCOFrameSize :: ByteOffset +offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader) + +offsetStgClosurePayload :: WordOffset +offsetStgClosurePayload = byteOffsetToWordOffset $ + (#const OFFSET_StgClosure_payload) + (#size StgHeader) + +sizeStgClosure :: Int +sizeStgClosure = bytesToWords (#size StgHeader) + +byteOffsetToWordOffset :: ByteOffset -> WordOffset +byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger + +bytesToWords :: Int -> Int +bytesToWords b = + if b `mod` bytesInWord == 0 then + fromIntegral $ b `div` bytesInWord + else + error "Unexpected struct alignment!" + +bytesInWord :: Int +bytesInWord = (#const SIZEOF_VOID_P) + ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -0,0 +1,499 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.Internal.Stack.Decode ( + decodeStack, + decodeStackWithIpe, + prettyStackFrameWithIpe, + -- * StackEntry + StackEntry(..), + prettyStackEntry, + decode, + ) +where + +import GHC.Internal.Base +import GHC.Internal.Show +import GHC.Internal.Real +import GHC.Internal.Word +import GHC.Internal.Num +import GHC.Internal.Data.Bits +import GHC.Internal.Data.Functor +import GHC.Internal.Data.List +import GHC.Internal.Data.Tuple +import GHC.Internal.Foreign.Ptr +import GHC.Internal.Foreign.Storable +import GHC.Internal.Exts +import GHC.Internal.Unsafe.Coerce + +import GHC.Internal.ClosureTypes +import GHC.Internal.Heap.Closures + ( Box (..), + StackFrame, + GenStackFrame (..), + StgStackClosure, + GenStgStackClosure (..), + StackField, + GenStackField(..) + ) +import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS) +import GHC.Internal.Heap.InfoTable +import GHC.Internal.Stack.Annotation +import GHC.Internal.Stack.Constants +import GHC.Internal.Stack.CloneStack +import GHC.Internal.InfoProv.Types (InfoProv (..), lookupIPE) + +{- Note [Decoding the stack] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + +The stack is represented by a chain of StgStack closures. Each of these closures +is subject to garbage collection. I.e. they can be moved in memory (in a +simplified perspective) at any time. + +The array of closures inside an StgStack (that makeup the execution stack; the +stack frames) is moved as bare memory by the garbage collector. References +(pointers) to stack frames are not updated by the garbage collector. + +As the StgStack closure is moved as whole, the relative offsets inside it stay +the same. (Though, the absolute addresses change!) + +Decoding +======== + +Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and +their relative offset. This tuple is described by `StackFrameLocation`. + +`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we +have to deal with three cases: + +- If the payload can only be a closure, we put it in a `Box` for later decoding + by the heap closure functions. + +- If the payload can either be a closure or a word-sized value (this happens for + bitmap-encoded payloads), we use a `StackField` which is a sum type to + represent either a `Word` or a `Box`. + +- Fields that are just simple (i.e. non-closure) values are decoded as such. + +The decoding happens in two phases: + +1. The whole stack is decoded into `StackFrameLocation`s. + +2. All `StackFrameLocation`s are decoded into `StackFrame`s. + +`StackSnapshot#` parameters are updated by the garbage collector and thus safe +to hand around. + +The head of the stack frame array has offset (index) 0. To traverse the stack +frames the latest stack frame's offset is incremented by the closure size. The +unit of the offset is machine words (32bit or 64bit.) + +IO +== + +Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames` +also being decoded in `IO`, due to references to `Closure`s. + +Technical details +================= + +- All access to StgStack/StackSnapshot# closures is made through Cmm code. This + keeps the closure from being moved by the garbage collector during the + operation. + +- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is + implemented in Cmm and C. It's just easier to reuse existing helper macros and + functions, than reinventing them in Haskell. + +- Offsets and sizes of closures are imported from DerivedConstants.h via HSC. + This keeps the code very portable. +-} + +foreign import prim "getUnderflowFrameNextChunkzh" + getUnderflowFrameNextChunk# :: + StackSnapshot# -> Word# -> StackSnapshot# + +getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot +getUnderflowFrameNextChunk stackSnapshot# index = + StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "getWordzh" + getWord# :: + StackSnapshot# -> Word# -> Word# + +getWord :: StackSnapshot# -> WordOffset -> Word +getWord stackSnapshot# index = + W# (getWord# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int# + +isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool +isArgGenBigRetFunType stackSnapshot# index = + I# (isArgGenBigRetFunType# stackSnapshot# (wordOffsetToWord# index)) > 0 + +-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size. +type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #) + +foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter + +-- | Gets contents of a small bitmap (fitting in one @StgWord@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the bitmap and it's size. +type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #) + +foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) + +foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# + +-- | Get the 'StgInfoTable' of the stack frame. +-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack stackSnapshot# index = + let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) + in + (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr#) + +getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable +getInfoTableForStack stackSnapshot# = + peekItbl $ + Ptr (getStackInfoTableAddr# stackSnapshot#) + +foreign import prim "getStackClosurezh" + getStackClosure# :: + StackSnapshot# -> Word# -> Any + +foreign import prim "getStackFieldszh" + getStackFields# :: + StackSnapshot# -> Word32# + +getStackFields :: StackSnapshot# -> Word32 +getStackFields stackSnapshot# = + case getStackFields# stackSnapshot# of + sSize# -> W32# sSize# + +-- | `StackFrameLocation` of the top-most stack frame +stackHead :: StackSnapshot# -> StackFrameLocation +stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty + +-- | Advance to the next stack frame (if any) +-- +-- The last `Int#` in the result tuple is meant to be treated as bool +-- (has_next). +foreign import prim "advanceStackFrameLocationzh" + advanceStackFrameLocation# :: + StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #) + +-- | Advance to the next stack frame (if any) +advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation +advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) = + let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) + in if I# hasNext > 0 + then Just (StackSnapshot s', primWordToWordOffset i') + else Nothing + where + primWordToWordOffset :: Word# -> WordOffset + primWordToWordOffset w# = fromIntegral (W# w#) + +getClosureBox :: StackSnapshot# -> WordOffset -> Box +getClosureBox stackSnapshot# index = + case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of + -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and + -- will later be decoded as such) + !c -> Box c + +-- | Representation of @StgLargeBitmap@ (RTS) +data LargeBitmap = LargeBitmap + { largeBitmapSize :: Word, + largebitmapWords :: Ptr Word + } + +-- | Is a bitmap entry a closure pointer or a primitive non-pointer? +data Pointerness = Pointer | NonPointer + deriving (Show) + +decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] +decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do + let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#) + bitmapWords <- largeBitmapToList largeBitmap + pure $ decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords) + where + largeBitmapToList :: LargeBitmap -> IO [Word] + largeBitmapToList LargeBitmap {..} = + cWordArrayToList largebitmapWords $ + (usedBitmapWords . fromIntegral) largeBitmapSize + + cWordArrayToList :: Ptr Word -> Int -> IO [Word] + cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)] + + usedBitmapWords :: Int -> Int + usedBitmapWords 0 = error "Invalid large bitmap size 0." + usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1 + + bitmapWordsPointerness :: Word -> [Word] -> [Pointerness] + bitmapWordsPointerness size _ | size <= 0 = [] + bitmapWordsPointerness _ [] = [] + bitmapWordsPointerness size (w : wds) = + bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w + ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds + +bitmapWordPointerness :: Word -> Word -> [Pointerness] +bitmapWordPointerness 0 _ = [] +bitmapWordPointerness bSize bitmapWord = + ( if (bitmapWord .&. 1) /= 0 + then NonPointer + else Pointer + ) + : bitmapWordPointerness + (bSize - 1) + (bitmapWord `shiftR` 1) + +decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField] +decodeBitmaps stack# index ps = + zipWith toPayload ps [index ..] + where + toPayload :: Pointerness -> WordOffset -> StackField + toPayload p i = case p of + NonPointer -> StackWord (getWord stack# i) + Pointer -> StackBox (getClosureBox stack# i) + +decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [StackField] +decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = + let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# b#, s# #) -> (W# b#, W# s#) + in decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordPointerness size bitmap) + +unpackStackFrame :: StackFrameLocation -> IO StackFrame +unpackStackFrame stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ info nextChunk -> do + stackClosure <- decodeStack nextChunk + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + ) + (\ frame _ -> pure frame) + +unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] +unpackStackFrameWithIpe stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ _ nextChunk -> do + decodeStackWithIpe nextChunk + ) + (\ frame mIpe -> pure [(frame, mIpe)]) + +unpackStackFrameTo :: + forall a . + StackFrameLocation -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> Maybe InfoProv -> IO a) -> + IO a +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do + (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index + unpackStackFrame' info + (`finaliseStackFrame` m_info_prov) + where + unpackStackFrame' :: + StgInfoTable -> + (StackFrame -> IO a) -> + IO a + unpackStackFrame' info mkStackFrameResult = + case tipe info of + RET_BCO -> do + let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload) + -- The arguments begin directly after the payload's one element + bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) + mkStackFrameResult + RetBCO + { info_tbl = info, + bco = bco', + bcoArgs = bcoArgs' + } + RET_SMALL -> + let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload + in + mkStackFrameResult $ + RetSmall + { info_tbl = info, + stack_payload = payload' + } + RET_BIG -> do + payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload + mkStackFrameResult $ + RetBig + { info_tbl = info, + stack_payload = payload' + } + RET_FUN -> do + let retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize) + retFunFun' = getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun) + retFunPayload' <- + if isArgGenBigRetFunType stackSnapshot# index == True + then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload + else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload + mkStackFrameResult $ + RetFun + { info_tbl = info, + retFunSize = retFunSize', + retFunFun = retFunFun', + retFunPayload = retFunPayload' + } + UPDATE_FRAME -> + let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) + in + mkStackFrameResult $ + UpdateFrame + { info_tbl = info, + updatee = updatee' + } + CATCH_FRAME -> do + let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) + mkStackFrameResult $ + CatchFrame + { info_tbl = info, + handler = handler' + } + UNDERFLOW_FRAME -> do + let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index + unpackUnderflowFrame info nextChunk' + STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} + ATOMICALLY_FRAME -> do + let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) + result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) + mkStackFrameResult $ + AtomicallyFrame + { info_tbl = info, + atomicallyFrameCode = atomicallyFrameCode', + result = result' + } + CATCH_RETRY_FRAME -> + let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode) + first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) + alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) + in + mkStackFrameResult $ + CatchRetryFrame + { info_tbl = info, + running_alt_code = running_alt_code', + first_code = first_code', + alt_code = alt_code' + } + CATCH_STM_FRAME -> + let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) + handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) + in + mkStackFrameResult $ + CatchStmFrame + { info_tbl = info, + catchFrameCode = catchFrameCode', + handler = handler' + } + ANN_FRAME -> + let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) + in + mkStackFrameResult $ + AnnFrame + { info_tbl = info, + annotation = annotation + } + x -> error $ "Unexpected closure type on stack: " ++ show x + +-- | Unbox 'Int#' from 'Int' +toInt# :: Int -> Int# +toInt# (I# i) = i + +-- | Convert `Int` to `Word#` +intToWord# :: Int -> Word# +intToWord# i = int2Word# (toInt# i) + +wordOffsetToWord# :: WordOffset -> Word# +wordOffsetToWord# wo = intToWord# (fromIntegral wo) + +-- | Location of a stackframe on the stack +-- +-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom +-- of the stack. +type StackFrameLocation = (StackSnapshot, WordOffset) + +-- | Decode `StackSnapshot` to a `StgStackClosure` +-- +-- The return value is the representation of the @StgStack@ itself. +-- +-- See /Note [Decoding the stack]/. +decodeStack :: StackSnapshot -> IO StgStackClosure +decodeStack snapshot@(StackSnapshot stack#) = do + (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot + pure + GenStgStackClosure + { ssc_info = stackInfo, + ssc_stack_size = getStackFields stack#, + ssc_stack = ssc_stack + } + +decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)] +decodeStackWithIpe snapshot = + concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot + +decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a]) +decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do + info <- getInfoTableForStack stack# + case tipe info of + STACK -> do + let sfls = stackFrameLocations stack# + stack' <- mapM unpackFrame sfls + pure (info, stack') + _ -> error $ "Expected STACK closure, got " ++ show info + where + stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] + stackFrameLocations s# = + stackHead s# + : go (advanceStackFrameLocation (stackHead s#)) + where + go :: Maybe StackFrameLocation -> [StackFrameLocation] + go Nothing = [] + go (Just r) = r : go (advanceStackFrameLocation r) + +prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String +prettyStackFrameWithIpe (frame, mipe) = + case frame of + AnnFrame _ (Box ann) -> + Just $ displayStackAnnotation (unsafeCoerce ann :: SomeStackAnnotation) + _ -> + (prettyStackEntry . toStackEntry) <$> mipe + + +-- TODO @fendor: deprecate +prettyStackEntry :: StackEntry -> String +prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) = + mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dda9f19838c09d3253c62351a49aae1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dda9f19838c09d3253c62351a49aae1... You're receiving this email because of your account on gitlab.haskell.org.