ghc-heap (empty) → 9.0.1
raw patch · 12 files changed
+1167/−0 lines, 12 filesdep +basedep +ghc-primdep +rtssetup-changed
Dependencies added: base, ghc-prim, rts
Files
- GHC/Exts/Heap.hs +285/−0
- GHC/Exts/Heap/ClosureTypes.hs +102/−0
- GHC/Exts/Heap/Closures.hs +365/−0
- GHC/Exts/Heap/Constants.hsc +17/−0
- GHC/Exts/Heap/InfoTable.hsc +73/−0
- GHC/Exts/Heap/InfoTable/Types.hsc +40/−0
- GHC/Exts/Heap/InfoTableProf.hsc +66/−0
- GHC/Exts/Heap/Utils.hsc +129/−0
- LICENSE +30/−0
- Setup.hs +6/−0
- cbits/HeapPrim.cmm +13/−0
- ghc-heap.cabal +41/−0
+ GHC/Exts/Heap.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module : GHC.Exts.Heap+Copyright : (c) 2012 Joachim Breitner+License : BSD3+Maintainer : Joachim Breitner <mail@joachim-breitner.de>++With this module, you can investigate the heap representation of Haskell+values, i.e. to investigate sharing and lazy evaluation.+-}++module GHC.Exts.Heap (+ -- * Closure types+ Closure+ , GenClosure(..)+ , ClosureType(..)+ , PrimType(..)+ , HasHeapRep(getClosureData)++ -- * Info Table types+ , StgInfoTable(..)+ , EntryFunPtr+ , HalfWord+ , ItblCodes+ , itblSize+ , peekItbl+ , pokeItbl++ -- * Closure inspection+ , getBoxedClosureData+ , allClosures++ -- * Boxes+ , Box(..)+ , asBox+ , areBoxesEqual+ ) where++import Prelude+import GHC.Exts.Heap.Closures+import GHC.Exts.Heap.ClosureTypes+import GHC.Exts.Heap.Constants+#if defined(PROFILING)+import GHC.Exts.Heap.InfoTableProf+#else+import GHC.Exts.Heap.InfoTable+#endif+import GHC.Exts.Heap.Utils++import Control.Monad+import Data.Bits+import GHC.Arr+import GHC.Exts+import GHC.Int+import GHC.Word++#include "ghcconfig.h"++class HasHeapRep (a :: TYPE rep) where+ getClosureData :: a -> IO Closure++instance HasHeapRep (a :: TYPE 'LiftedRep) where+ getClosureData = getClosure++instance HasHeapRep (a :: TYPE 'UnliftedRep) where+ getClosureData x = getClosure (unsafeCoerce# x)++instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where+ getClosureData x = return $+ IntClosure { ptipe = PInt, intVal = I# x }++instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where+ getClosureData x = return $+ WordClosure { ptipe = PWord, wordVal = W# x }++instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where+ getClosureData x = return $+ Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }++instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where+ getClosureData x = return $+ Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }++instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where+ getClosureData x = return $+ AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }++instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where+ getClosureData x = return $+ FloatClosure { ptipe = PFloat, floatVal = F# x }++instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where+ getClosureData x = return $+ DoubleClosure { ptipe = PDouble, doubleVal = D# x }++-- | This returns the raw representation of the given argument. The second+-- component of the triple is the raw words of the closure on the heap, and the+-- third component is those words that are actually pointers. Once back in the+-- Haskell world, the raw words that hold pointers may be outdated after a+-- garbage collector run, but the corresponding values in 'Box's will still+-- point to the correct value.+getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])+getClosureRaw x = do+ case unpackClosure# x of+-- This is a hack to cover the bootstrap compiler using the old version of+-- 'unpackClosure'. The new 'unpackClosure' return values are not merely+-- a reordering, so using the old version would not work.+ (# iptr, dat, pointers #) -> do+ let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE+ end = fromIntegral nelems - 1+ rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]+ pelems = I# (sizeofArray# pointers)+ ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers+ pure (Ptr iptr, rawWds, ptrList)++-- From GHC.Runtime.Heap.Inspect+amap' :: (t -> b) -> Array Int t -> [b]+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]+ where g (I# i#) = case indexArray# arr# i# of+ (# e #) -> f e++-- | This function returns a parsed heap representation of the argument _at+-- this moment_, even if it is unevaluated or an indirection or other exotic+-- stuff. Beware when passing something to this function, the same caveats as+-- for 'asBox' apply.+getClosure :: a -> IO Closure+getClosure x = do+ (iptr, wds, pts) <- getClosureRaw x+ itbl <- peekItbl iptr+ -- The remaining words after the header+ let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds+ -- For data args in a pointers then non-pointers closure+ -- This is incorrect in non pointers-first setups+ -- not sure if that happens+ npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds+ case tipe itbl of+ t | t >= CONSTR && t <= CONSTR_NOCAF -> do+ (p, m, n) <- dataConNames iptr+ if m == "GHC.ByteCode.Instr" && n == "BreakInfo"+ then pure $ UnsupportedClosure itbl+ else pure $ ConstrClosure itbl pts npts p m n++ t | t >= THUNK && t <= THUNK_STATIC -> do+ pure $ ThunkClosure itbl pts npts++ THUNK_SELECTOR -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to THUNK_SELECTOR"+ pure $ SelectorClosure itbl (head pts)++ t | t >= FUN && t <= FUN_STATIC -> do+ pure $ FunClosure itbl pts npts++ AP -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to AP"+ -- We expect at least the arity, n_args, and fun fields+ unless (length rawWds >= 2) $+ fail $ "Expected at least 2 raw words to AP"+ let splitWord = rawWds !! 0+ pure $ APClosure itbl+#if defined(WORDS_BIGENDIAN)+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))+ (fromIntegral splitWord)+#else+ (fromIntegral splitWord)+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))+#endif+ (head pts) (tail pts)++ PAP -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to PAP"+ -- We expect at least the arity, n_args, and fun fields+ unless (length rawWds >= 2) $+ fail "Expected at least 2 raw words to PAP"+ let splitWord = rawWds !! 0+ pure $ PAPClosure itbl+#if defined(WORDS_BIGENDIAN)+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))+ (fromIntegral splitWord)+#else+ (fromIntegral splitWord)+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))+#endif+ (head pts) (tail pts)++ AP_STACK -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to AP_STACK"+ pure $ APStackClosure itbl (head pts) (tail pts)++ IND -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to IND"+ pure $ IndClosure itbl (head pts)++ IND_STATIC -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to IND_STATIC"+ pure $ IndClosure itbl (head pts)++ BLACKHOLE -> do+ unless (length pts >= 1) $+ fail "Expected at least 1 ptr argument to BLACKHOLE"+ pure $ BlackholeClosure itbl (head pts)++ BCO -> do+ unless (length pts >= 3) $+ fail $ "Expected at least 3 ptr argument to BCO, found "+ ++ show (length pts)+ unless (length rawWds >= 4) $+ fail $ "Expected at least 4 words to BCO, found "+ ++ show (length rawWds)+ let splitWord = rawWds !! 3+ pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)+#if defined(WORDS_BIGENDIAN)+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))+ (fromIntegral splitWord)+#else+ (fromIntegral splitWord)+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))+#endif+ (drop 4 rawWds)++ ARR_WORDS -> do+ unless (length rawWds >= 1) $+ fail $ "Expected at least 1 words to ARR_WORDS, found "+ ++ show (length rawWds)+ pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)++ t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do+ unless (length rawWds >= 2) $+ fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "+ ++ "found " ++ show (length rawWds)+ pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts++ t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do+ unless (length rawWds >= 1) $+ fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "+ ++ "found " ++ show (length rawWds)+ pure $ SmallMutArrClosure itbl (rawWds !! 0) pts++ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->+ pure $ MutVarClosure itbl (head pts)++ t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do+ unless (length pts >= 3) $+ fail $ "Expected at least 3 ptrs to MVAR, found "+ ++ show (length pts)+ pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)++ BLOCKING_QUEUE ->+ pure $ OtherClosure itbl pts wds+ -- pure $ BlockingQueueClosure itbl+ -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)++ -- pure $ OtherClosure itbl pts wds+ --++ WEAK ->+ pure $ WeakClosure+ { info = itbl+ , cfinalizers = pts !! 0+ , key = pts !! 1+ , value = pts !! 2+ , finalizer = pts !! 3+ , link = pts !! 4+ }++ _ ->+ pure $ UnsupportedClosure itbl++-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.+getBoxedClosureData :: Box -> IO Closure+getBoxedClosureData (Box a) = getClosureData a
+ GHC/Exts/Heap/ClosureTypes.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}++module GHC.Exts.Heap.ClosureTypes+ ( ClosureType(..)+ , closureTypeHeaderSize+ ) where++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Generics++{- ---------------------------------------------+-- Enum representing closure types+-- This is a mirror of:+-- includes/rts/storage/ClosureTypes.h+-- ---------------------------------------------}++data ClosureType+ = INVALID_OBJECT+ | CONSTR+ | CONSTR_1_0+ | CONSTR_0_1+ | CONSTR_2_0+ | CONSTR_1_1+ | CONSTR_0_2+ | CONSTR_NOCAF+ | FUN+ | FUN_1_0+ | FUN_0_1+ | FUN_2_0+ | FUN_1_1+ | FUN_0_2+ | FUN_STATIC+ | THUNK+ | THUNK_1_0+ | THUNK_0_1+ | THUNK_2_0+ | THUNK_1_1+ | THUNK_0_2+ | THUNK_STATIC+ | THUNK_SELECTOR+ | BCO+ | AP+ | PAP+ | AP_STACK+ | IND+ | IND_STATIC+ | RET_BCO+ | RET_SMALL+ | RET_BIG+ | RET_FUN+ | UPDATE_FRAME+ | CATCH_FRAME+ | UNDERFLOW_FRAME+ | STOP_FRAME+ | BLOCKING_QUEUE+ | BLACKHOLE+ | MVAR_CLEAN+ | MVAR_DIRTY+ | TVAR+ | ARR_WORDS+ | MUT_ARR_PTRS_CLEAN+ | MUT_ARR_PTRS_DIRTY+ | MUT_ARR_PTRS_FROZEN_DIRTY+ | MUT_ARR_PTRS_FROZEN_CLEAN+ | MUT_VAR_CLEAN+ | MUT_VAR_DIRTY+ | WEAK+ | PRIM+ | MUT_PRIM+ | TSO+ | STACK+ | TREC_CHUNK+ | ATOMICALLY_FRAME+ | CATCH_RETRY_FRAME+ | CATCH_STM_FRAME+ | WHITEHOLE+ | SMALL_MUT_ARR_PTRS_CLEAN+ | SMALL_MUT_ARR_PTRS_DIRTY+ | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY+ | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN+ | COMPACT_NFDATA+ | N_CLOSURE_TYPES+ deriving (Enum, Eq, Ord, Show, Generic)++-- | Return the size of the closures header in words+closureTypeHeaderSize :: ClosureType -> Int+closureTypeHeaderSize closType =+ case closType of+ ct | THUNK <= ct && ct <= THUNK_0_2 -> thunkHeader+ ct | ct == THUNK_SELECTOR -> thunkHeader+ ct | ct == AP -> thunkHeader+ ct | ct == AP_STACK -> thunkHeader+ _ -> header+ where+ header = 1 + prof+ thunkHeader = 2 + prof+#if defined(PROFILING)+ prof = 2+#else+ prof = 0+#endif
+ GHC/Exts/Heap/Closures.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}++module GHC.Exts.Heap.Closures (+ -- * Closures+ Closure+ , GenClosure(..)+ , PrimType(..)+ , allClosures+#if __GLASGOW_HASKELL__ >= 809+ -- The closureSize# primop is unsupported on earlier GHC releases but we+ -- build ghc-heap as a boot library so it must be buildable. Drop this once+ -- we are guaranteed to bootstsrap with GHC >= 8.9.+ , closureSize+#endif++ -- * Boxes+ , Box(..)+ , areBoxesEqual+ , asBox+ ) where++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Exts.Heap.Constants+#if defined(PROFILING)+import GHC.Exts.Heap.InfoTableProf+#else+import GHC.Exts.Heap.InfoTable++-- `ghc -M` currently doesn't properly account for ways when generating+-- dependencies (#15197). This import ensures correct build-ordering between+-- this module and GHC.Exts.Heap.InfoTableProf. It should be removed when #15197+-- is fixed.+import GHC.Exts.Heap.InfoTableProf ()+#endif++import Data.Bits+import Data.Int+import Data.Word+import GHC.Exts+import GHC.Generics+import Numeric++------------------------------------------------------------------------+-- 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/includes/rts/storage/Closures.h>+--+-- The data type is parametrized by 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+ , link :: !b -- ^ next weak pointer for the capability, can be NULL.+ }++ ------------------------------------------------------------+ -- 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 :: !Int }++ -- | 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+ }+ deriving (Show, Generic, Functor, Foldable, Traversable)+++data PrimType+ = PInt+ | PWord+ | PInt64+ | PWord64+ | PAddr+ | PFloat+ | PDouble+ deriving (Eq, Show, Generic)++-- | 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, link]+allClosures (OtherClosure {..}) = hvalues+allClosures _ = []++#if __GLASGOW_HASKELL__ >= 809+-- | 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)+#endif
+ GHC/Exts/Heap/Constants.hsc view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP #-}++module GHC.Exts.Heap.Constants+ ( wORD_SIZE+ , tAG_MASK+ , wORD_SIZE_IN_BITS+ ) where++#include "MachDeps.h"++import Prelude -- See note [Why do we import Prelude here?]+import Data.Bits++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
+ GHC/Exts/Heap/InfoTable.hsc view
@@ -0,0 +1,73 @@+module GHC.Exts.Heap.InfoTable+ ( module GHC.Exts.Heap.InfoTable.Types+ , itblSize+ , peekItbl+ , pokeItbl+ ) where++#include "Rts.h"++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Exts.Heap.InfoTable.Types+#if !defined(TABLES_NEXT_TO_CODE)+import GHC.Exts.Heap.Constants+import Data.Maybe+#endif+import Foreign++-------------------------------------------------------------------------+-- 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 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 (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_)
+ GHC/Exts/Heap/InfoTable/Types.hsc view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}+module GHC.Exts.Heap.InfoTable.Types+ ( StgInfoTable(..)+ , EntryFunPtr+ , HalfWord+ , ItblCodes+ ) where++#include "Rts.h"++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Generics+import GHC.Exts.Heap.ClosureTypes+import Foreign++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++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/includes/rts/storage/InfoTables.h>+-- 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 (Show, Generic)
+ GHC/Exts/Heap/InfoTableProf.hsc view
@@ -0,0 +1,66 @@+module GHC.Exts.Heap.InfoTableProf+ ( module GHC.Exts.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 Prelude -- See note [Why do we import Prelude here?]+import GHC.Exts.Heap.InfoTable.Types+#if !defined(TABLES_NEXT_TO_CODE)+import GHC.Exts.Heap.Constants+import Data.Maybe+#endif+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+-- 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_)
+ GHC/Exts/Heap/Utils.hsc view
@@ -0,0 +1,129 @@+{-# LANGUAGE CPP, MagicHash #-}++module GHC.Exts.Heap.Utils (+ dataConNames+ ) where++#include "Rts.h"++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Exts.Heap.Constants+import GHC.Exts.Heap.InfoTable++import Data.Char+import Data.List+import Foreign+import GHC.CString+import GHC.Exts++{- To find the string in the constructor's info table we need to consider+ the layout of info tables relative to the entry code for a closure.++ An info table can be next to the entry code for the closure, or it can+ be separate. The former (faster) is used in registerised versions of ghc,+ and the latter (portable) is for non-registerised versions.++ The diagrams below show where the string is to be found relative to+ the normal info table of the closure.++ 1) Tables next to code:++ --------------+ | | <- pointer to the start of the string+ --------------+ | | <- the (start of the) info table structure+ | |+ | |+ --------------+ | entry code |+ | .... |++ In this case the pointer to the start of the string can be found in+ the memory location _one word before_ the first entry in the normal info+ table.++ 2) Tables NOT next to code:++ --------------+ info table structure -> | *------------------> --------------+ | | | entry code |+ | | | .... |+ --------------+ ptr to start of str -> | |+ --------------++ In this case the pointer to the start of the string can be found+ in the memory location: info_table_ptr + info_table_size+-}++-- Given a ptr to an 'StgInfoTable' for a data constructor+-- return (Package, Module, Name)+dataConNames :: Ptr StgInfoTable -> IO (String, String, String)+dataConNames ptr = do+ conDescAddress <- getConDescAddress+ pure $ parse conDescAddress+ where+ -- Retrieve the con_desc field address pointing to+ -- 'Package:Module.Name' string+ getConDescAddress :: IO (Ptr Word8)+ getConDescAddress+#if defined(TABLES_NEXT_TO_CODE)+ = do+ offsetToString <- peek (ptr `plusPtr` negate wORD_SIZE)+ pure $ (ptr `plusPtr` stdInfoTableSizeB)+ `plusPtr` fromIntegral (offsetToString :: Int32)+#else+ = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral stdInfoTableSizeB+#endif++ stdInfoTableSizeW :: Int+ -- The size of a standard info table varies with profiling/ticky etc,+ -- so we can't get it from Constants+ -- It must vary in sync with mkStdInfoTable+ stdInfoTableSizeW+ = size_fixed + size_prof+ where+ size_fixed = 2 -- layout, type+##if defined(PROFILING)+ size_prof = 2+##else+ size_prof = 0+##endif++ stdInfoTableSizeB :: Int+ stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE++-- parsing names is a little bit fiddly because we have a string in the form:+-- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").+-- Thus we split at the leftmost colon and the rightmost occurrence of the dot.+-- It would be easier if the string was in the form pkg:A.B.C:foo, but alas+-- this is not the conventional way of writing Haskell names. We stick with+-- convention, even though it makes the parsing code more troublesome.+-- Warning: this code assumes that the string is well formed.+parse :: Ptr Word8 -> (String, String, String)+parse (Ptr addr) = if not . all (>0) . fmap length $ [p,m,occ]+ then ([], [], input)+ else (p, m, occ)+ where+ input = unpackCStringUtf8## addr+ (p, rest1) = break (== ':') input+ (m, occ)+ = (intercalate "." $ reverse modWords, occWord)+ where+ (modWords, occWord) =+ if length rest1 < 1 -- XXXXXXXXx YUKX+ --then error "getConDescAddress:parse:length rest1 < 1"+ then parseModOcc [] []+ else parseModOcc [] (tail rest1)+ -- We only look for dots if str could start with a module name,+ -- i.e. if it starts with an upper case character.+ -- Otherwise we might think that "X.:->" is the module name in+ -- "X.:->.+", whereas actually "X" is the module name and+ -- ":->.+" is a constructor name.+ parseModOcc :: [String] -> String -> ([String], String)+ parseModOcc acc str@(c : _)+ | isUpper c =+ case break (== '.') str of+ (top, []) -> (acc, top)+ (top, _:bot) -> parseModOcc (top : acc) bot+ parseModOcc acc str = (acc, str)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012-2013, Joachim Breitner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Joachim Breitner nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ cbits/HeapPrim.cmm view
@@ -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);+}
+ ghc-heap.cabal view
@@ -0,0 +1,41 @@+cabal-version: 3.0+name: ghc-heap+version: 9.0.1+license: BSD-3-Clause+license-file: LICENSE+maintainer: libraries@haskell.org+bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new+synopsis: Functions for walking GHC's heap+category: GHC+description:+ This package provides functions for walking the GHC heap data structures+ and retrieving information about those data structures.++build-type: Simple+tested-with: GHC==7.11++source-repository head+ type: git+ location: https://gitlab.haskell.org/ghc/ghc.git+ subdir: libraries/ghc-heap++library+ default-language: Haskell2010++ build-depends: base >= 4.9.0 && < 5.0+ , ghc-prim > 0.2 && < 0.8+ , rts == 1.0.*++ ghc-options: -Wall+ cmm-sources: cbits/HeapPrim.cmm++ default-extensions: NoImplicitPrelude++ exposed-modules: GHC.Exts.Heap+ GHC.Exts.Heap.Closures+ GHC.Exts.Heap.ClosureTypes+ GHC.Exts.Heap.Constants+ GHC.Exts.Heap.InfoTable+ GHC.Exts.Heap.InfoTable.Types+ GHC.Exts.Heap.InfoTableProf+ GHC.Exts.Heap.Utils