diff options
Diffstat (limited to 'libraries/ghc-heap/GHC/Exts')
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap.hs | 254 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs | 98 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 313 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc | 16 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc | 77 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc | 37 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc | 73 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc | 128 |
8 files changed, 996 insertions, 0 deletions
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs new file mode 100644 index 0000000000..3dd204d3c5 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -0,0 +1,254 @@ +{-# 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 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 + +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. +#if MIN_VERSION_ghc_prim(0,5,2) + (# iptr, dat, pointers #) -> do +#else + (# iptr, pointers, dat #) -> do +#endif + 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 compiler/ghci/RtClosureInspect.hs +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 == "ByteCodeInstr" && 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 + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (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 + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (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) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (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 -> 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 == 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 + -- + _ -> + 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 diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs new file mode 100644 index 0000000000..507561fbee --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.ClosureTypes + ( ClosureType(..) + , closureTypeHeaderSize + ) where + +{- --------------------------------------------- +-- 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_FROZEN0 + | MUT_ARR_PTRS_FROZEN + | 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_FROZEN0 + | SMALL_MUT_ARR_PTRS_FROZEN + | COMPACT_NFDATA + | N_CLOSURE_TYPES + deriving (Enum, Eq, Ord, Show) + +-- | 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 diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs new file mode 100644 index 0000000000..f355a62510 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.Exts.Heap.Closures ( + -- * Closures + Closure + , GenClosure(..) + , PrimType(..) + , allClosures + + -- * Boxes + , Box(..) + , areBoxesEqual + , asBox + ) where + +import GHC.Exts.Heap.Constants +#if defined(PROFILING) +import GHC.Exts.Heap.InfoTableProf +#else +import GHC.Exts.Heap.InfoTable +#endif + +import Data.Bits +import Data.Int +import Data.Word +import GHC.Exts +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 + -- want 0s prefixed to pad it out to a fixed length. + pad_out ls = + '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ 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 +-- <http://hackage.haskell.org/trac/ghc/browser/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://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects> +-- 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 + } + + -- | 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 + } + + -- | A @MutVar#@ + | MutVarClosure + { info :: !StgInfoTable + , var :: !b -- ^ Pointer to closure + } + + -- | 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 -- ^ ?? + } + + ------------------------------------------------------------ + -- 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) + + +data PrimType + = PInt + | PWord + | PInt64 + | PWord64 + | PAddr + | PFloat + | PDouble + deriving (Eq, Show) + +-- | 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 (MutVarClosure {..}) = [var] +allClosures (MVarClosure {..}) = [queueHead,queueTail,value] +allClosures (FunClosure {..}) = ptrArgs +allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] +allClosures (OtherClosure {..}) = hvalues +allClosures _ = [] diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc b/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc new file mode 100644 index 0000000000..757e76ce23 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.Constants + ( wORD_SIZE + , tAG_MASK + , wORD_SIZE_IN_BITS + ) where + +#include "MachDeps.h" + +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 diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc new file mode 100644 index 0000000000..d6f1ab0e95 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc @@ -0,0 +1,77 @@ +module GHC.Exts.Heap.InfoTable + ( module GHC.Exts.Heap.InfoTable.Types + , itblSize + , peekItbl + , pokeItbl + ) where + +#include "Rts.h" + +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 +#if __GLASGOW_HASKELL__ > 804 + srtlen' <- (#peek struct StgInfoTable_, srt) a0 +#else + srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr +#endif + 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)) +#if __GLASGOW_HASKELL__ > 804 + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#else + (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl) +#endif +#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 + +-- | Size in bytes of a standard InfoTable +itblSize :: Int +itblSize = (#size struct StgInfoTable_) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc new file mode 100644 index 0000000000..d8666d6b1d --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc @@ -0,0 +1,37 @@ +module GHC.Exts.Heap.InfoTable.Types + ( StgInfoTable(..) + , EntryFunPtr + , HalfWord + , ItblCodes + ) where + +#include "Rts.h" + +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 +-- <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h> +-- for more details on this data structure. +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: ClosureType, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode + } deriving (Show) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc new file mode 100644 index 0000000000..cd030bfa1a --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc @@ -0,0 +1,73 @@ +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 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 +#if __GLASGOW_HASKELL__ > 804 + srtlen' <- (#peek struct StgInfoTable_, srt) a0 +#else + srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr +#endif + 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)) +#if __GLASGOW_HASKELL__ > 804 + (#poke StgInfoTable, srt) a0 (srtlen itbl) +#else + (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl) +#endif +#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_) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc new file mode 100644 index 0000000000..3f09700225 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP, MagicHash #-} + +module GHC.Exts.Heap.Utils ( + dataConNames + ) where + +#include "Rts.h" + +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) |