diff options
Diffstat (limited to 'libraries')
20 files changed, 1555 insertions, 110 deletions
diff --git a/libraries/ghc-heap/.gitignore b/libraries/ghc-heap/.gitignore new file mode 100644 index 0000000000..7eba14b857 --- /dev/null +++ b/libraries/ghc-heap/.gitignore @@ -0,0 +1,5 @@ +GNUmakefile +/dist-install/ +/dist/ +ghc.mk +heapview.cabal 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) diff --git a/libraries/ghc-heap/LICENSE b/libraries/ghc-heap/LICENSE new file mode 100644 index 0000000000..682cb5ac5c --- /dev/null +++ b/libraries/ghc-heap/LICENSE @@ -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. diff --git a/libraries/ghc-heap/Setup.hs b/libraries/ghc-heap/Setup.hs new file mode 100644 index 0000000000..6fa548caf7 --- /dev/null +++ b/libraries/ghc-heap/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/libraries/ghc-heap/cbits/HeapPrim.cmm b/libraries/ghc-heap/cbits/HeapPrim.cmm new file mode 100644 index 0000000000..915786de28 --- /dev/null +++ b/libraries/ghc-heap/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); +} diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in new file mode 100644 index 0000000000..780dda3fd0 --- /dev/null +++ b/libraries/ghc-heap/ghc-heap.cabal.in @@ -0,0 +1,38 @@ +cabal-version: 2.1 +name: ghc-heap +version: @ProjectVersionMunged@ +license: BSD-3-Clause +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://ghc.haskell.org/trac/ghc/newticket +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: http://git.haskell.org/ghc.git + subdir: libraries/heapview + +library + default-language: Haskell2010 + + build-depends: base >= 4.9.0 && < 5.0 + , ghc-prim > 0.2 && < 0.6 + , rts == 1.0.* + + ghc-options: -Wall + cmm-sources: cbits/HeapPrim.cmm + 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 diff --git a/libraries/ghc-heap/tests/Makefile b/libraries/ghc-heap/tests/Makefile new file mode 100644 index 0000000000..6a0abcf1cf --- /dev/null +++ b/libraries/ghc-heap/tests/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T new file mode 100644 index 0000000000..a676b4971a --- /dev/null +++ b/libraries/ghc-heap/tests/all.T @@ -0,0 +1,8 @@ +test('heap_all', + [when(have_profiling(), + extra_ways(['prof'])), + # These ways produce slightly different heap representations. + # Currently we don't test them. + omit_ways(['ghci', 'hpc']) + ], + compile_and_run, ['']) diff --git a/libraries/ghc-heap/tests/heap_all.hs b/libraries/ghc-heap/tests/heap_all.hs new file mode 100644 index 0000000000..76da037034 --- /dev/null +++ b/libraries/ghc-heap/tests/heap_all.hs @@ -0,0 +1,421 @@ +-- The simplifier changes the shapes of closures that we expect. +{-# OPTIONS_GHC -O0 #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} + +import GHC.Exts.Heap + +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Monad +import GHC.Exts +import GHC.Int +import GHC.IO +import GHC.IORef +import GHC.MVar +import GHC.Stack +import GHC.STRef +import GHC.Word +import System.Environment +import System.Mem + +exData :: (Int,Int) +exData = (1,2) + +exItbl :: StgInfoTable +exItbl = StgInfoTable + { entry = Nothing + , ptrs = 0 + , nptrs = 0 + , tipe = toEnum 0 + , srtlen = 0 + , code = Nothing + } + +exConstrClosure :: Closure +exConstrClosure = ConstrClosure + { info = exItbl{tipe=CONSTR_1_0, ptrs=1, nptrs=0} + , ptrArgs = [] + , dataArgs = [] + , pkg = "base" + , modl = "GHC.Base" + , name = "Just" + } + +exFunClosure :: Closure +exFunClosure = FunClosure + { info = exItbl{tipe=FUN_0_1, ptrs=0, nptrs=1} + , ptrArgs = [] + , dataArgs = [0] + } + +exThunkClosure :: Closure +exThunkClosure = ThunkClosure + { info = exItbl{tipe=THUNK} + , ptrArgs = [] + , dataArgs = [] + } + +exSelectClosure :: Closure +exSelectClosure = SelectorClosure + { info = exItbl + , selectee = asBox exData + } + +exPAPClosure :: Closure +exPAPClosure = PAPClosure + { info = exItbl{tipe=PAP} + , arity = 1 + , n_args = 1 + , fun = asBox id + , payload = [] + } + +exAPClosure :: Closure +exAPClosure = APClosure + { info = exItbl{tipe=AP} + , arity = 0 + , n_args = 0 + , fun = asBox id + , payload = [] + } + +exAPStackClosure :: Closure +exAPStackClosure = APStackClosure + { info = exItbl{tipe=AP_STACK} + , fun = asBox id + , payload = [] + } + +exIndClosure :: Closure +exIndClosure = IndClosure + { info = exItbl{tipe=IND} + , indirectee = asBox [] + } + +exBCOClosure :: Closure +exBCOClosure = BCOClosure + { info = exItbl{tipe=BCO, ptrs=4} + , instrs = asBox [] + , literals = asBox [] + , bcoptrs = asBox [] + , arity = 0 + , size = 5 + , bitmap = [] + } + +exBlackholeClosure :: Closure +exBlackholeClosure = BlackholeClosure + { info = exItbl{tipe=BLACKHOLE} + , indirectee = asBox [] + } + +exArrWordsClosure :: Closure +exArrWordsClosure = ArrWordsClosure + { info = exItbl{tipe=ARR_WORDS} + , bytes = 0 + , arrWords = [] + } + +exMutArrClosure :: Closure +exMutArrClosure = MutArrClosure + { info = exItbl{tipe=MUT_ARR_PTRS_DIRTY} + , mccPtrs = 0 + , mccSize = 0 + , mccPayload = [] + } + +exMVarClosure :: Closure +exMVarClosure = MVarClosure + { info = exItbl{tipe=MVAR_DIRTY} + , queueHead = asBox [] + , queueTail = asBox [] + , value = asBox 0 + } + +exMutVarClosure :: Closure +exMutVarClosure = MutVarClosure + { info = exItbl{tipe=MUT_VAR_DIRTY} + , var = asBox [] + } + +exBlockingQClosure :: Closure +exBlockingQClosure = BlockingQueueClosure + { info = exItbl{tipe=BLOCKING_QUEUE} + , link = asBox [] + , blackHole = asBox [] + , owner = asBox [] + , queue = asBox [] + } + +exIntClosure :: Closure +exIntClosure = IntClosure + { ptipe = PInt, intVal = 42 } + +exWordClosure :: Closure +exWordClosure = WordClosure + { ptipe = PWord, wordVal = 42 } + +exInt64Closure :: Closure +exInt64Closure = Int64Closure + { ptipe = PInt64, int64Val = 42 } + +exWord64Closure :: Closure +exWord64Closure = Word64Closure + { ptipe = PWord64, word64Val = 42 } + +exAddrClosure :: Closure +exAddrClosure = AddrClosure + { ptipe = PAddr, addrVal = 42 } + +exFloatClosure :: Closure +exFloatClosure = FloatClosure + { ptipe = PFloat, floatVal = 42.0 } + +exDoubleClosure :: Closure +exDoubleClosure = DoubleClosure + { ptipe = PDouble, doubleVal = 42.0 } + +exOtherClosure :: Closure +exOtherClosure = OtherClosure + { info = exItbl + , hvalues = [] + , rawWords = [] + } + +data A = A (Array# Int) +data MA = MA (MutableArray# RealWorld Int) +data BA = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) +data B = B BCO# +data APC a = APC a + +main :: IO () +main = do + + -------------------------------------------- + -- Objects to inspect + + MA ma <- IO $ \s -> + case newArray# 0# 0 s of + (# s1, x #) -> (# s1, MA x #) + A a <- IO $ \s -> + case freezeArray# ma 0# 0# s of + (# s1, x #) -> (# s1, A x #) + MBA mba <- IO $ \s -> + case newByteArray# 0# s of + (# s1, x #) -> (# s1, MBA x #) + BA ba <- IO $ \s -> + case newByteArray# 0# s of + (# s1, x #) -> + case unsafeFreezeByteArray# x s1 of + (# s2, y #) -> (# s2, BA y #) + B bco <- IO $ \s -> + case newBCO# ba ba a 0# ba s of + (# s1, x #) -> (# s1, B x #) + APC apc <- IO $ \s -> + case mkApUpd0# bco of + (# x #) -> (# s, APC x #) + + -------------------------------------------- + -- Closures + + -- Constructor + let !con = Just 1 + getClosureData con >>= + assertClosuresEq exConstrClosure + + -- Function + let !fun = \x -> x + 1 + getClosureData fun >>= + assertClosuresEq exFunClosure + + -- Thunk + let thunk = map (+2) [1,2,3] + getClosureData thunk >>= + assertClosuresEq exThunkClosure + + -- Selector + -- FAILING: Getting THUNK not THUNK_SELECTOR + -- let sel = case exData of (a,_) -> a + -- getClosureData sel >>= + -- assertClosuresEq exSelectClosure + + -- Partial application + let !f = map (+2) + getClosureData f >>= + assertClosuresEq exPAPClosure + + -- Applied function + getClosureData apc >>= + assertClosuresEq exAPClosure + + -- Suspended thunk evaluation + -- getClosureData (Just 1) >>= + -- assertClosuresEq exAPStackClosure + + -- Indirection + -- getClosureData (Just 1) >>= + -- assertClosuresEq exIndClosure + + -- ByteCode object + getClosureData bco >>= + assertClosuresEq exBCOClosure + + -- Blackhole + -- getClosureData (Just 1) >>= + -- assertClosuresEq exBlackholeClosure + + -- Byte array + getClosureData ba >>= + assertClosuresEq exArrWordsClosure + + -- Mutable pointer array + getClosureData ma >>= + assertClosuresEq exMutArrClosure + + -- MVar + (MVar v) <- newMVar 1 + getClosureData (unsafeCoerce# v) >>= + assertClosuresEq exMVarClosure + + -- MutVar + (IORef (STRef v)) <- newIORef 1 + getClosureData v >>= + assertClosuresEq exMutVarClosure + + -- Blocking queue + -- getClosureData (Just 1) >>= + -- assertClosuresEq exBlockingQClosure + + ----------------------------------------------------- + -- Unboxed unlifted types + + -- Primitive Int + let (I# v) = 42 + getClosureData v >>= + assertClosuresEq exIntClosure + + -- Primitive Word + let (W# v) = 42 + getClosureData v >>= + assertClosuresEq exWordClosure + + -- Primitive Int64 + -- FAILING: On 64-bit platforms, v is a regular Int + -- let (I64# v) = 42 + -- getClosureData v >>= + -- assertClosuresEq exInt64Closure + + -- Primitive Word64 + -- FAILING: On 64-bit platforms, v is a regular Word + -- let (W64# v) = 42 + -- getClosureData v >>= + -- assertClosuresEq exWord64Closure + + -- Primitive Addr + let v = unsafeCoerce# 42# :: Addr# + getClosureData v >>= + assertClosuresEq exAddrClosure + + -- Primitive Float + let (F# v) = 42.0 + getClosureData v >>= + assertClosuresEq exFloatClosure + + -- Primitive Double + let (D# v) = 42.0 + getClosureData v >>= + assertClosuresEq exDoubleClosure + + ------------------------------------------------------ + -- Catch-all type + + -- Other + -- getClosureData (Just 1) >>= + -- assertClosuresEq exOtherClosure + + putStrLn "Done. No errors." + + +-- | Attempt to compare two closures +compareClosures :: Closure -> Closure -> Bool +compareClosures expected actual = + -- Determine which fields to compare based + -- upon expected closure type + let funcs = case expected of + ConstrClosure{} -> [ sEq (tipe . info) + , sEq (ptrs . info) + , sEq (nptrs . info) + , sEq dataArgs + , sEq name ] + FunClosure{} -> [ sEq (tipe . info) + , sEq (ptrs . info) + , sEq (nptrs . info) + , sEq dataArgs ] + ThunkClosure{} -> [ sEq (tipe . info) + , sEq (ptrs . info) + , sEq (nptrs . info) + , sEq dataArgs ] + SelectorClosure{} -> [ sEq (tipe . info) ] + PAPClosure{} -> [ sEq (tipe . info) + , sEq arity + , sEq n_args ] + APClosure{} -> [ sEq (tipe . info) + , sEq arity + , sEq n_args ] + APStackClosure{} -> [ sEq (tipe . info) ] + IndClosure{} -> [ sEq (tipe . info) ] + BCOClosure{} -> [ sEq (tipe . info) + , sEq arity + , sEq bitmap ] + BlackholeClosure{} -> [ sEq (tipe . info) ] + ArrWordsClosure{} -> [ sEq (tipe . info) + , sEq bytes + , sEq arrWords ] + MutArrClosure{} -> [ sEq (tipe . info) + , sEq mccPtrs + , sEq mccSize ] + MVarClosure{} -> [ sEq (tipe . info) ] + MutVarClosure{} -> [ sEq (tipe . info) ] + BlockingQueueClosure{} -> [ sEq (tipe . info) ] + IntClosure{} -> [ sEq ptipe + , sEq intVal ] + WordClosure{} -> [ sEq ptipe + , sEq wordVal ] + Int64Closure{} -> [ sEq ptipe + , sEq int64Val ] + Word64Closure{} -> [ sEq ptipe + , sEq word64Val ] + AddrClosure{} -> [ sEq ptipe + , sEq addrVal ] + FloatClosure{} -> [ sEq ptipe + , sEq floatVal ] + DoubleClosure{} -> [ sEq ptipe + , sEq doubleVal ] + _ -> error $ "Don't know how to compare expected closure: " + ++ show expected + in compareWith funcs expected actual + where + -- Take a list of closure comparisons and check all + compareWith :: [Closure -> Closure -> Bool] -> Closure -> Closure -> Bool + compareWith funcs c1 c2 = all (\f -> f c1 c2) funcs + + -- Create a comparison function from a selector + sEq :: Eq a => (Closure -> a) -> Closure -> Closure -> Bool + sEq select c1 c2 = select c1 == select c2 + +-- | Assert two closures are equal, checking depending on closure type +assertClosuresEq :: HasCallStack => Closure -> Closure -> IO () +assertClosuresEq _ c@UnsupportedClosure{} = + fail $ unlines [ "Unsupported closure returned: " ++ show c + , "" + , prettyCallStack callStack + ] +assertClosuresEq expected actual = + unless (compareClosures expected actual) $ fail $ unlines + [ "assertClosuresEq: Closures do not match" + , "Expected: " ++ show expected + , "Actual: " ++ show actual + , "" + , prettyCallStack callStack + ] diff --git a/libraries/ghc-heap/tests/heap_all.stdout b/libraries/ghc-heap/tests/heap_all.stdout new file mode 100644 index 0000000000..b747b9bd7b --- /dev/null +++ b/libraries/ghc-heap/tests/heap_all.stdout @@ -0,0 +1 @@ +Done. No errors. diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index afcfefc7fa..cd712ba925 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -9,75 +9,20 @@ -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable - ( peekItbl, StgInfoTable(..) - , conInfoPtr + ( #ifdef GHCI - , mkConInfoTable + mkConInfoTable #endif ) where -#if !defined(TABLES_NEXT_TO_CODE) -import Data.Maybe (fromJust) -#endif +#ifdef GHCI import Foreign -import Foreign.C -- needed for 2nd stage -import GHC.Ptr -- needed for 2nd stage -import GHC.Exts -- needed for 2nd stage -import System.IO.Unsafe -- needed for 2nd stage - -type ItblCodes = Either [Word8] [Word32] - --- 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 +import Foreign.C +import GHC.Ptr +import GHC.Exts +import GHC.Exts.Heap #endif -type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) - -data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: HalfWord, - srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode - } - -peekItbl :: Ptr StgInfoTable -> IO StgInfoTable -peekItbl a0 = do -#if defined(TABLES_NEXT_TO_CODE) - let entry' = Nothing -#else - entry' <- Just <$> (#peek StgInfoTable, entry) a0 -#endif - ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0 - nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0 - tipe' <- (#peek StgInfoTable, type) a0 -#if __GLASGOW_HASKELL__ > 804 - srtlen' <- (#peek StgInfoTable, srt) a0 -#else - srtlen' <- (#peek StgInfoTable, srt_bitmap) a0 -#endif - return StgInfoTable - { entry = entry' - , ptrs = ptrs' - , nptrs = nptrs' - , tipe = tipe' - , srtlen = srtlen' - , code = Nothing - } - --- | Convert a pointer to an StgConInfo into an info pointer that can be --- used in the header of a closure. -conInfoPtr :: Ptr () -> Ptr () -conInfoPtr ptr - | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable) - | otherwise = ptr - ghciTablesNextToCode :: Bool #ifdef TABLES_NEXT_TO_CODE ghciTablesNextToCode = True @@ -86,6 +31,9 @@ ghciTablesNextToCode = False #endif #ifdef GHCI /* To end */ +-- NOTE: Must return a pointer acceptable for use in the header of a closure. +-- If tables_next_to_code is enabled, then it must point the the 'code' field. +-- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable :: Int -- ptr words -> Int -- non-ptr words @@ -107,7 +55,7 @@ mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc = else Just entry_addr, ptrs = fromIntegral ptr_words, nptrs = fromIntegral nonptr_words, - tipe = fromIntegral cONSTR, + tipe = CONSTR, srtlen = fromIntegral tag, code = if ghciTablesNextToCode then Just code' @@ -373,11 +321,16 @@ pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () pokeConItbl wr_ptr ex_ptr itbl = do - let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB) #if defined(TABLES_NEXT_TO_CODE) - (#poke StgConInfoTable, con_desc) wr_ptr _con_desc + -- Write the offset to the con_desc from the end of the standard InfoTable + -- at the first byte. + let con_desc_offset = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB) + (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset #else - (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl) + -- Write the con_desc address after the end of the info table. + -- Use itblSize because CPP will not pick up PROFILING when calculating + -- the offset. + pokeByteOff wr_ptr itblSize (conDesc itbl) #endif pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl) @@ -389,32 +342,14 @@ sizeOfEntryCode Left xs -> sizeOf (head xs) * length xs Right xs -> sizeOf (head xs) * length xs -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 (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 - +-- Note: Must return proper pointer for use in a closure newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ()) newExecConItbl obj con_desc = alloca $ \pcode -> do let lcon_desc = length con_desc + 1{- null terminator -} - sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode) + -- SCARY + -- This size represents the number of bytes in an StgConInfoTable. + sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode) -- Note: we need to allocate the conDesc string next to the info -- table, because on a 64-bit platform we reference this string -- with a 32-bit offset relative to the info table, so if we @@ -426,7 +361,11 @@ newExecConItbl obj con_desc pokeConItbl wr_ptr ex_ptr cinfo pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc _flushExec sz ex_ptr -- Cache flush (if needed) +#if defined(TABLES_NEXT_TO_CODE) + return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB)) +#else return (castPtrToFunPtr ex_ptr) +#endif foreign import ccall unsafe "allocateExec" _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) @@ -440,26 +379,6 @@ foreign import ccall unsafe "flushExec" wORD_SIZE :: Int wORD_SIZE = (#const SIZEOF_HSINT) -fixedInfoTableSizeB :: Int -fixedInfoTableSizeB = 2 * wORD_SIZE - -profInfoTableSizeB :: Int -profInfoTableSizeB = (#size StgProfInfo) - -stdInfoTableSizeB :: Int -stdInfoTableSizeB - = (if ghciTablesNextToCode then 0 else wORD_SIZE) - + (if rtsIsProfiled then profInfoTableSizeB else 0) - + fixedInfoTableSizeB - conInfoTableSizeB :: Int -conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE - -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt - -rtsIsProfiled :: Bool -rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 - -cONSTR :: Int -- Defined in ClosureTypes.h -cONSTR = (#const CONSTR) +conInfoTableSizeB = wORD_SIZE + itblSize #endif /* GHCI */ diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index f69fff29ff..3f0bad9888 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -23,12 +23,12 @@ module GHCi.Message ) where import GHCi.RemoteTypes -import GHCi.InfoTable (StgInfoTable) import GHCi.FFI import GHCi.TH.Binary () import GHCi.BreakArray import GHC.LanguageExtensions +import GHC.Exts.Heap import GHC.ForeignSrcLang import GHC.Fingerprint import Control.Concurrent diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index bacc70fa88..47f65afe14 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -77,6 +77,7 @@ library filepath == 1.4.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, + ghc-heap == @ProjectVersionMunged@, template-haskell == 2.14.*, transformers == 0.5.* |