summaryrefslogtreecommitdiff
path: root/libraries/ghc-heap
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/ghc-heap')
-rw-r--r--libraries/ghc-heap/.gitignore5
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap.hs254
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs98
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/Closures.hs313
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc16
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc77
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc37
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc73
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc128
-rw-r--r--libraries/ghc-heap/LICENSE30
-rw-r--r--libraries/ghc-heap/Setup.hs6
-rw-r--r--libraries/ghc-heap/cbits/HeapPrim.cmm13
-rw-r--r--libraries/ghc-heap/ghc-heap.cabal.in38
-rw-r--r--libraries/ghc-heap/tests/Makefile7
-rw-r--r--libraries/ghc-heap/tests/all.T8
-rw-r--r--libraries/ghc-heap/tests/heap_all.hs421
-rw-r--r--libraries/ghc-heap/tests/heap_all.stdout1
17 files changed, 1525 insertions, 0 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.
View Lorry Controller Status