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

1 files changed, 254 insertions, 0 deletions

diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
new file mode 100644
index 0000000000..3dd204d3c5
--- /dev/null
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -0,0 +1,254 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-|
+Module      :  GHC.Exts.Heap
+Copyright   :  (c) 2012 Joachim Breitner
+License     :  BSD3
+Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
+
+With this module, you can investigate the heap representation of Haskell
+values, i.e. to investigate sharing and lazy evaluation.
+-}
+
+module GHC.Exts.Heap (
+    -- * Closure types
+      Closure
+    , GenClosure(..)
+    , ClosureType(..)
+    , PrimType(..)
+    , HasHeapRep(getClosureData)
+
+    -- * Info Table types
+    , StgInfoTable(..)
+    , EntryFunPtr
+    , HalfWord
+    , ItblCodes
+    , itblSize
+    , peekItbl
+    , pokeItbl
+
+     -- * Closure inspection
+    , getBoxedClosureData
+    , allClosures
+
+    -- * Boxes
+    , Box(..)
+    , asBox
+    , areBoxesEqual
+    ) where
+
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Constants
+#if defined(PROFILING)
+import GHC.Exts.Heap.InfoTableProf
+#else
+import GHC.Exts.Heap.InfoTable
+#endif
+import GHC.Exts.Heap.Utils
+
+import Control.Monad
+import Data.Bits
+import GHC.Arr
+import GHC.Exts
+import GHC.Int
+import GHC.Word
+
+class HasHeapRep (a :: TYPE rep) where
+    getClosureData :: a -> IO Closure
+
+instance HasHeapRep (a :: TYPE 'LiftedRep) where
+    getClosureData = getClosure
+
+instance HasHeapRep (a :: TYPE 'UnliftedRep) where
+    getClosureData x = getClosure (unsafeCoerce# x)
+
+instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
+    getClosureData x = return $
+        IntClosure { ptipe = PInt, intVal = I# x }
+
+instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
+    getClosureData x = return $
+        WordClosure { ptipe = PWord, wordVal = W# x }
+
+instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
+    getClosureData x = return $
+        Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }
+
+instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
+    getClosureData x = return $
+        Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }
+
+instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
+    getClosureData x = return $
+        AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }
+
+instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
+    getClosureData x = return $
+        FloatClosure { ptipe = PFloat, floatVal = F# x }
+
+instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
+    getClosureData x = return $
+        DoubleClosure { ptipe = PDouble, doubleVal = D# x }
+
+-- | This returns the raw representation of the given argument. The second
+-- component of the triple is the raw words of the closure on the heap, and the
+-- third component is those words that are actually pointers. Once back in the
+-- Haskell world, the raw words that hold pointers may be outdated after a
+-- garbage collector run, but the corresponding values in 'Box's will still
+-- point to the correct value.
+getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
+getClosureRaw x = do
+    case unpackClosure# x of
+-- This is a hack to cover the bootstrap compiler using the old version of
+-- 'unpackClosure'. The new 'unpackClosure' return values are not merely
+-- a reordering, so using the old version would not work.
+#if MIN_VERSION_ghc_prim(0,5,2)
+        (# iptr, dat, pointers #) -> do
+#else
+        (# iptr, pointers, dat #) -> do
+#endif
+            let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
+                end = fromIntegral nelems - 1
+                rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
+                pelems = I# (sizeofArray# pointers)
+                ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
+            pure (Ptr iptr, rawWds, ptrList)
+
+-- From compiler/ghci/RtClosureInspect.hs
+amap' :: (t -> b) -> Array Int t -> [b]
+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
+    where g (I# i#) = case indexArray# arr# i# of
+                          (# e #) -> f e
+
+-- | This function returns a parsed heap representation of the argument _at
+-- this moment_, even if it is unevaluated or an indirection or other exotic
+-- stuff.  Beware when passing something to this function, the same caveats as
+-- for 'asBox' apply.
+getClosure :: a -> IO Closure
+getClosure x = do
+    (iptr, wds, pts) <- getClosureRaw x
+    itbl <- peekItbl iptr
+    -- The remaining words after the header
+    let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
+    -- For data args in a pointers then non-pointers closure
+    -- This is incorrect in non pointers-first setups
+    -- not sure if that happens
+        npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds
+    case tipe itbl of
+        t | t >= CONSTR && t <= CONSTR_NOCAF -> do
+            (p, m, n) <- dataConNames iptr
+            if m == "ByteCodeInstr" && n == "BreakInfo"
+              then pure $ UnsupportedClosure itbl
+              else pure $ ConstrClosure itbl pts npts p m n
+
+        t | t >= THUNK && t <= THUNK_STATIC -> do
+            pure $ ThunkClosure itbl pts npts
+
+        THUNK_SELECTOR -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
+            pure $ SelectorClosure itbl (head pts)
+
+        t | t >= FUN && t <= FUN_STATIC -> do
+            pure $ FunClosure itbl pts npts
+
+        AP -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to AP"
+            -- We expect at least the arity, n_args, and fun fields
+            unless (length rawWds >= 2) $
+                fail $ "Expected at least 2 raw words to AP"
+            let splitWord = rawWds !! 0
+            pure $ APClosure itbl
+                (fromIntegral splitWord)
+                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                (head pts) (tail pts)
+
+        PAP -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to PAP"
+            -- We expect at least the arity, n_args, and fun fields
+            unless (length rawWds >= 2) $
+                fail "Expected at least 2 raw words to PAP"
+            let splitWord = rawWds !! 0
+            pure $ PAPClosure itbl
+                (fromIntegral splitWord)
+                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                (head pts) (tail pts)
+
+        AP_STACK -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to AP_STACK"
+            pure $ APStackClosure itbl (head pts) (tail pts)
+
+        IND -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to IND"
+            pure $ IndClosure itbl (head pts)
+
+        IND_STATIC -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to IND_STATIC"
+            pure $ IndClosure itbl (head pts)
+
+        BLACKHOLE -> do
+            unless (length pts >= 1) $
+                fail "Expected at least 1 ptr argument to BLACKHOLE"
+            pure $ BlackholeClosure itbl (head pts)
+
+        BCO -> do
+            unless (length pts >= 3) $
+                fail $ "Expected at least 3 ptr argument to BCO, found "
+                        ++ show (length pts)
+            unless (length rawWds >= 4) $
+                fail $ "Expected at least 4 words to BCO, found "
+                        ++ show (length rawWds)
+            let splitWord = rawWds !! 3
+            pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
+                (fromIntegral splitWord)
+                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                (drop 4 rawWds)
+
+        ARR_WORDS -> do
+            unless (length rawWds >= 1) $
+                fail $ "Expected at least 1 words to ARR_WORDS, found "
+                        ++ show (length rawWds)
+            pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)
+
+        t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN -> do
+            unless (length rawWds >= 2) $
+                fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
+                        ++ "found " ++ show (length rawWds)
+            pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts
+
+        t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
+            pure $ MutVarClosure itbl (head pts)
+
+        t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
+            unless (length pts >= 3) $
+                fail $ "Expected at least 3 ptrs to MVAR, found "
+                        ++ show (length pts)
+            pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
+
+        BLOCKING_QUEUE ->
+            pure $ OtherClosure itbl pts wds
+        --    pure $ BlockingQueueClosure itbl
+        --        (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
+
+        --  pure $ OtherClosure itbl pts wds
+        --
+        _ ->
+            pure $ UnsupportedClosure itbl
+
+-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
+getBoxedClosureData :: Box -> IO Closure
+getBoxedClosureData (Box a) = getClosureData a