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

4 files changed, 98 insertions, 298 deletions

diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index bea431185c..e7eb7108f9 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -23,7 +23,6 @@ import GhcPrelude
 
 import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
-import GHCi.InfoTable
 import GHCi.BreakArray
 import SizedSeq
 
@@ -99,7 +98,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do
 lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
 lookupIE hsc_env ie con_nm =
   case lookupNameEnv ie con_nm of
-    Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
+    Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
     Nothing -> do -- try looking up in the object files.
        let sym_to_find1 = nameToCLabel con_nm "con_info"
        m <- lookupSymbol hsc_env sym_to_find1
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
index ecb9d2212f..628b576ca0 100644
--- a/compiler/ghci/ByteCodeTypes.hs
+++ b/compiler/ghci/ByteCodeTypes.hs
@@ -27,7 +27,6 @@ import SrcLoc
 import GHCi.BreakArray
 import GHCi.RemoteTypes
 import GHCi.FFI
-import GHCi.InfoTable
 import Control.DeepSeq
 
 import Foreign
@@ -36,6 +35,7 @@ import Data.Array.Base  ( UArray(..) )
 import Data.ByteString (ByteString)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
+import GHC.Exts.Heap
 import GHC.Stack.CCS
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
deleted file mode 100644
index 9af98c1bcf..0000000000
--- a/compiler/ghci/DebuggerUtils.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module DebuggerUtils (
-       dataConInfoPtrToName,
-  ) where
-
-import GhcPrelude
-
-import GHCi.InfoTable
-import CmmInfo ( stdInfoTableSizeB )
-import DynFlags
-import HscTypes
-import FastString
-import IfaceEnv
-import Module
-import OccName
-import Name
-import Outputable
-import Util
-
-import Data.Char
-import Foreign
-import Data.List
-
-#include "HsVersions.h"
-
--- | Given a data constructor in the heap, find its Name.
---   The info tables for data constructors have a field which records
---   the source name of the constructor as a Ptr Word8 (UTF-8 encoded
---   string). The format is:
---
---   > Package:Module.Name
---
---   We use this string to lookup the interpreter's internal representation of the name
---   using the lookupOrig.
---
-dataConInfoPtrToName :: HscEnv -> Ptr () -> IO Name
-dataConInfoPtrToName hsc_env x = do
-   let dflags = hsc_dflags hsc_env
-   theString <- do
-     let ptr = castPtr x :: Ptr StgInfoTable
-     conDescAddress <- getConDescAddress dflags ptr
-     peekArray0 0 conDescAddress
-   let (pkg, mod, occ) = parse theString
-       pkgFS = mkFastStringByteList pkg
-       modFS = mkFastStringByteList mod
-       occFS = mkFastStringByteList occ
-       occName = mkOccNameFS OccName.dataName occFS
-       modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)
-   lookupOrigIO hsc_env modName occName
-
-   where
-
-   {- 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) Code next to table:
-
-         --------------
-         |            |   <- 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) Code NOT next to table:
-
-                                 --------------
-         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
-   -}
-
-   getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
-   getConDescAddress dflags ptr
-    | ghciTablesNextToCode = do
-       let ptr' = ptr `plusPtr` (- wORD_SIZE dflags)
-       -- NB. the offset must be read as an Int32 not a Word32, so
-       -- that the sign is preserved when converting to an Int.
-       offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32)
-       return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString
-    | otherwise =
-       peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
-   -- 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 :: [Word8] -> ([Word8], [Word8], [Word8])
-   parse input
-      = ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ)
-      where
-      dot = fromIntegral (ord '.')
-      (pkg, rest1) = break (== fromIntegral (ord ':')) input
-      (mod, occ)
-         = (concat $ intersperse [dot] $ reverse modWords, occWord)
-         where
-         (modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1))
-      parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
-      -- 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 acc str@(c : _)
-       | isUpper $ chr $ fromIntegral c
-         = case break (== dot) str of
-              (top, []) -> (acc, top)
-              (top, _ : bot) -> parseModOcc (top : acc) bot
-      parseModOcc acc str = (acc, str)
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index d7e1267d97..025efe8cb2 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -21,17 +21,14 @@ module RtClosureInspect(
 
 --     unsafeDeepSeq,
 
-     Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
+     constrClosToName, isConstr, isIndirection
  ) where
 
 #include "HsVersions.h"
 
 import GhcPrelude
 
-import DebuggerUtils
-import GHCi.RemoteTypes ( HValue )
-import qualified GHCi.InfoTable as InfoTable
-import GHCi.InfoTable (StgInfoTable, peekItbl)
+import GHCi.RemoteTypes
 import HscTypes
 
 import DataCon
@@ -48,6 +45,9 @@ import TcEnv
 
 import TyCon
 import Name
+import OccName
+import Module
+import IfaceEnv
 import Util
 import VarSet
 import BasicTypes       ( Boxity(..) )
@@ -56,16 +56,14 @@ import PrelNames
 import TysWiredIn
 import DynFlags
 import Outputable as Ppr
-import GHC.Arr          ( Array(..) )
 import GHC.Char
 import GHC.Exts
+import GHC.Exts.Heap
 import GHC.IO ( IO(..) )
 import SMRep ( roundUpTo )
 
 import Control.Monad
 import Data.Maybe
-import Data.Array.Base
-import Data.Ix
 import Data.List
 import qualified Data.Sequence as Seq
 import Data.Sequence (viewl, ViewL(..))
@@ -86,7 +84,7 @@ data Term = Term { ty        :: RttiType
                  , subTerms  :: [Term] }
 
           | Prim { ty        :: RttiType
-                 , value     :: [Word] }
+                 , valRaw    :: [Word] }
 
           | Suspension { ctype    :: ClosureType
                        , ty       :: RttiType
@@ -114,7 +112,13 @@ isPrim   _    = False
 isNewtypeWrap NewtypeWrap{} = True
 isNewtypeWrap _             = False
 
-isFun Suspension{ctype=Fun} = True
+isFun Suspension{ctype=FUN} = True
+isFun Suspension{ctype=FUN_1_0} = True
+isFun Suspension{ctype=FUN_0_1} = True
+isFun Suspension{ctype=FUN_2_0} = True
+isFun Suspension{ctype=FUN_1_1} = True
+isFun Suspension{ctype=FUN_0_2} = True
+isFun Suspension{ctype=FUN_STATIC} = True
 isFun _ = False
 
 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
@@ -134,101 +138,30 @@ instance Outputable (Term) where
  ppr t | Just doc <- cPprTerm cPprTermBase t = doc
        | otherwise = panic "Outputable Term instance"
 
--------------------------------------------------------------------------
--- Runtime Closure Datatype and functions for retrieving closure related stuff
--------------------------------------------------------------------------
-data ClosureType = Constr
-                 | Fun
-                 | Thunk Int
-                 | ThunkSelector
-                 | Blackhole
-                 | AP
-                 | PAP
-                 | Indirection Int
-                 | MutVar Int
-                 | MVar   Int
-                 | Other  Int
- deriving (Show, Eq)
-
-data ClosureNonPtrs = ClosureNonPtrs ByteArray#
-
-data Closure = Closure { tipe         :: ClosureType
-                       , infoPtr      :: Ptr ()
-                       , infoTable    :: StgInfoTable
-                       , ptrs         :: Array Int HValue
-                       , nonPtrs      :: ClosureNonPtrs
-                       }
+----------------------------------------
+-- Runtime Closure information functions
+----------------------------------------
 
-instance Outputable ClosureType where
-  ppr = text . show
-
-#include "../includes/rts/storage/ClosureTypes.h"
-
-aP_CODE, pAP_CODE :: Int
-aP_CODE = AP
-pAP_CODE = PAP
-#undef AP
-#undef PAP
-
-getClosureData :: DynFlags -> a -> IO Closure
-getClosureData dflags a =
-   case unpackClosure# a of
-     (# iptr, ptrs, nptrs #) -> do
-           let iptr0 = Ptr iptr
-           let iptr1
-                | ghciTablesNextToCode = iptr0
-                | otherwise =
-                   -- the info pointer we get back from unpackClosure#
-                   -- is to the beginning of the standard info table,
-                   -- but the Storable instance for info tables takes
-                   -- into account the extra entry pointer when
-                   -- !ghciTablesNextToCode, so we must adjust here:
-                   iptr0 `plusPtr` negate (wORD_SIZE dflags)
-           itbl <- peekItbl iptr1
-           let tipe = readCType (InfoTable.tipe itbl)
-               elems = fromIntegral (InfoTable.ptrs itbl)
-               ptrsList = Array 0 (elems - 1) elems ptrs
-               nptrs_data = ClosureNonPtrs nptrs
-           ASSERT(elems >= 0) return ()
-           ptrsList `seq`
-            return (Closure tipe iptr0 itbl ptrsList nptrs_data)
-
-readCType :: Integral a => a -> ClosureType
-readCType i
- | i >= CONSTR && i <= CONSTR_NOCAF        = Constr
- | i >= FUN    && i <= FUN_STATIC          = Fun
- | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
- | i == THUNK_SELECTOR                     = ThunkSelector
- | i == BLACKHOLE                          = Blackhole
- | i >= IND    && i <= IND_STATIC          = Indirection i'
- | i' == aP_CODE                           = AP
- | i == AP_STACK                           = AP
- | i' == pAP_CODE                          = PAP
- | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
- | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'
- | otherwise                               = Other  i'
-  where i' = fromIntegral i
-
-isConstr, isIndirection, isThunk :: ClosureType -> Bool
-isConstr Constr = True
+isConstr, isIndirection, isThunk :: GenClosure a -> Bool
+isConstr ConstrClosure{} = True
 isConstr    _   = False
 
-isIndirection (Indirection _) = True
+isIndirection IndClosure{} = True
 isIndirection _ = False
 
-isThunk (Thunk _)     = True
-isThunk ThunkSelector = True
-isThunk AP            = True
+isThunk ThunkClosure{} = True
+isThunk APClosure{} = True
+isThunk APStackClosure{} = True
 isThunk _             = False
 
-isFullyEvaluated :: DynFlags -> a -> IO Bool
-isFullyEvaluated dflags a = do
-  closure <- getClosureData dflags a
-  case tipe closure of
-    Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure)
-                 return$ and are_subs_evaluated
-    _      -> return False
-  where amapM f = sequence . amap' f
+isFullyEvaluated :: a -> IO Bool
+isFullyEvaluated a = do
+  closure <- getClosureData a
+  if isConstr closure
+    then do are_subs_evaluated <- amapM isFullyEvaluated (ptrArgs closure)
+            return$ and are_subs_evaluated
+    else return False
+  where amapM f = sequence . map (\(Box x) -> f x)
 
 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 {-
@@ -243,6 +176,15 @@ unsafeDeepSeq = unsafeDeepSeq1 2
         where tipe = unsafePerformIO (getClosureType a)
 -}
 
+-- Lookup the name in a constructor closure
+constrClosToName :: HscEnv -> Closure -> IO (Either String Name)
+constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
+   let occName = mkOccName OccName.dataName occ
+       modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
+   Right `fmap` lookupOrigIO hsc_env modName occName
+constrClosToName _hsc_env clos =
+   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show clos))
+
 -----------------------------------
 -- * Traversals for Terms
 -----------------------------------
@@ -374,7 +316,7 @@ ppr_termM _ _ t = ppr_termM1 t
 
 
 ppr_termM1 :: Monad m => Term -> m SDoc
-ppr_termM1 Prim{value=words, ty=ty} =
+ppr_termM1 Prim{valRaw=words, ty=ty} =
     return $ repPrim (tyConAppTyCon ty) words
 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
     return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
@@ -696,8 +638,6 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             text "Type obtained: " <> ppr (termType term))
    return term
     where
-  dflags = hsc_dflags hsc_env
-
   go :: Int -> Type -> Type -> HValue -> TcM Term
    -- I believe that my_ty should not have any enclosing
    -- foralls, nor any free RuntimeUnk skolems;
@@ -708,27 +648,30 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
   go 0 my_ty _old_ty a = do
     traceTR (text "Gave up reconstructing a term after" <>
                   int max_depth <> text " steps")
-    clos <- trIO $ getClosureData dflags a
-    return (Suspension (tipe clos) my_ty a Nothing)
+    clos <- trIO $ getClosureData a
+    return (Suspension (tipe (info clos)) my_ty a Nothing)
   go !max_depth my_ty old_ty a = do
     let monomorphic = not(isTyVarTy my_ty)
     -- This ^^^ is a convention. The ancestor tests for
     -- monomorphism and passes a type instead of a tv
-    clos <- trIO $ getClosureData dflags a
-    case tipe clos of
+    clos <- trIO $ getClosureData a
+    case clos of
 -- Thunks we may want to force
       t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
                                 seq a (go (pred max_depth) my_ty old_ty a)
 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE.  So we
 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
 -- showing '_' which is what we want.
-      Blackhole -> do traceTR (text "Following a BLACKHOLE")
-                      appArr (go max_depth my_ty old_ty) (ptrs clos) 0
+      BlackholeClosure{indirectee=ind} -> do
+         traceTR (text "Following a BLACKHOLE")
+         (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind
 -- We always follow indirections
-      Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
-                          go max_depth my_ty old_ty $! (ptrs clos ! 0)
+      IndClosure{indirectee=ind} -> do
+         traceTR (text "Following an indirection" )
+         (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind
 -- We also follow references
-      MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
+      MutVarClosure{}
+         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
              -> do
                   -- Deal with the MutVar# primitive
                   -- It does not have a constructor at all,
@@ -745,13 +688,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
          return (RefWrap my_ty x)
 
  -- The interesting case
-      Constr -> do
+      ConstrClosure{ptrArgs=pArgs} -> do
         traceTR (text "entering a constructor " <>
                       if monomorphic
                         then parens (text "already monomorphic: " <> ppr my_ty)
                         else Ppr.empty)
-        dcname    <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos)
-        (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing -> do -- This can happen for private constructors compiled -O0
                         -- where the .hi descriptor does not export them
@@ -761,10 +704,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                        traceTR (text "Not constructor" <+> ppr dcname)
                        let dflags = hsc_dflags hsc_env
                            tag = showPpr dflags dcname
-                       vars     <- replicateM (length$ elems$ ptrs clos)
+                       vars     <- replicateM (length pArgs)
                                               (newVar liftedTypeKind)
-                       subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
-                                              | (i, tv) <- zip [0..] vars]
+                       subTerms <- sequence $ zipWith (\(Box x) tv ->
+                           go (pred max_depth) tv tv (HValue x)) pArgs vars
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
             traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
@@ -773,9 +716,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             return (Term my_ty (Right dc) a subTerms)
 
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
-      tipe_clos -> do
-         traceTR (text "Unknown closure:" <+> ppr tipe_clos)
-         return (Suspension tipe_clos my_ty a Nothing)
+      _ -> do
+         traceTR (text "Unknown closure:" <+> text (show clos))
+         return (Suspension (tipe (info clos)) my_ty a Nothing)
 
   -- insert NewtypeWraps around newtypes
   expandNewtypes = foldTerm idTermFold { fTerm = worker } where
@@ -798,7 +741,7 @@ extractSubTerms :: (Type -> HValue -> TcM Term)
                 -> Closure -> [Type] -> TcM [Term]
 extractSubTerms recurse clos = liftM thdOf3 . go 0 0
   where
-    !(ClosureNonPtrs array) = nonPtrs clos
+    array = dataArgs clos
 
     go ptr_i arr_i [] = return (ptr_i, arr_i, [])
     go ptr_i arr_i (ty:tys)
@@ -829,7 +772,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
 
     go_rep ptr_i arr_i ty rep
       | isGcPtrRep rep = do
-          t <- appArr (recurse ty) (ptrs clos) ptr_i
+          t <- (\(Box x) -> recurse ty (HValue x)) $ (ptrArgs clos)!!ptr_i
           return (ptr_i + 1, arr_i, t)
       | otherwise = do
           -- This is a bit involved since we allow packing multiple fields
@@ -841,29 +784,34 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
               -- Fields are always aligned.
               !aligned_idx = roundUpTo arr_i size_b
               !new_arr_i = aligned_idx + size_b
-              ws
-                  | size_b < word_size = [index size_b array aligned_idx]
-                  | otherwise =
-                      let (q, r) = size_b `quotRem` word_size
-                      in ASSERT( r == 0 )
-                         [ W# (indexWordArray# array i)
-                         | o <- [0.. q - 1]
-                         , let !(I# i) = (aligned_idx + o) `quot` word_size
-                         ]
+              ws | size_b < word_size =
+                     [index size_b array aligned_idx word_size]
+                 | otherwise =
+                     let (q, r) = size_b `quotRem` word_size
+                     in ASSERT( r == 0 )
+                        [ array!!i
+                        | o <- [0.. q - 1]
+                        , let i = (aligned_idx `quot` word_size) + o
+                        ]
           return (ptr_i, new_arr_i, Prim ty ws)
 
     unboxedTupleTerm ty terms
       = Term ty (Right (tupleDataCon Unboxed (length terms)))
                 (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
 
-    index item_size_b  array (I# index_b) =
-        case item_size_b of
-            -- indexWord*Array# functions take offsets dependent not in bytes,
-            -- but in multiples of an element's size.
-            1 -> W# (indexWord8Array# array index_b)
-            2 -> W# (indexWord16Array# array (index_b `quotInt#` 2#))
-            4 -> W# (indexWord32Array# array (index_b `quotInt#` 4#))
-            _ -> panic ("Weird byte-index: " ++ show (I# index_b))
+    -- Extract a sub-word sized field from a word
+    index item_size_b array index_b word_size =
+        (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
+      where
+        mask :: Word
+        mask = case item_size_b of
+            1 -> 0xFF
+            2 -> 0xFFFF
+            4 -> 0xFFFFFFFF
+            _ -> panic ("Weird byte-index: " ++ show index_b)
+        (q,r) = index_b `quotRem` word_size
+        word = array!!q
+        moveBytes = r * 8
 
 
 -- Fast, breadth-first Type reconstruction
@@ -896,8 +844,6 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
    return new_ty
     where
-  dflags = hsc_dflags hsc_env
-
 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
                                 int max_depth <> text " steps")
@@ -912,32 +858,31 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
   go :: Type -> HValue -> TR [(Type, HValue)]
   go my_ty a = do
     traceTR (text "go" <+> ppr my_ty)
-    clos <- trIO $ getClosureData dflags a
-    case tipe clos of
-      Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
-      Indirection _ -> go my_ty $! (ptrs clos ! 0)
-      MutVar _ -> do
+    clos <- trIO $ getClosureData a
+    case clos of
+      BlackholeClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind
+      IndClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind
+      MutVarClosure{} -> do
          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
          tv'   <- newVar liftedTypeKind
          world <- newVar liftedTypeKind
          addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
          return [(tv', contents)]
-      Constr -> do
-        dcname    <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos)
+      ConstrClosure{ptrArgs=pArgs} -> do
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
         traceTR (text "Constr1" <+> ppr dcname)
         (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing-> do
-            forM (elems $ ptrs clos) $ \a -> do
+            forM pArgs $ \(Box x) -> do
               tv <- newVar liftedTypeKind
-              return (tv, a)
+              return (tv, HValue x)
 
           Just dc -> do
             arg_tys <- getDataConArgTys dc my_ty
             (_, itys) <- findPtrTyss 0 arg_tys
             traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
-            return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
-                     | (i,ty) <- itys]
+            return $ zipWith (\(_,ty) (Box x) -> (ty, HValue x)) itys pArgs
       _ -> return []
 
 findPtrTys :: Int  -- Current pointer index
@@ -1303,15 +1248,3 @@ quantifyType ty = ( filter isTyVar $
                   , rho)
   where
     (_tvs, rho) = tcSplitForAllTys ty
-
--- Strict application of f at index i
-appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
-appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
- = ASSERT2(i < length(elems a), ppr(length$ elems a, i))
-   case indexArray# ptrs# i# of
-       (# e #) -> f e
-
-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