Add HeapView functionality

This pulls parts of Joachim Breitner's ghc-heap-view library inside GHC.
The bits added are the C hooks into the RTS and a basic Haskell wrapper
to these C hooks. The main reason for these to be added to GHC proper
is that the code needs to be kept in sync with the closure types
defined by the RTS. It is expected that the version of HeapView shipped
with GHC will always work with that version of GHC and that extra
functionality can be layered on top with a library like ghc-heap-view
distributed via Hackage.

Test Plan: validate

Reviewers: simonmar, hvr, nomeata, austin, Phyx, bgamari, erikd

Reviewed By: bgamari

Subscribers: carter, patrickdoc, tmcgilchrist, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3055

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.*