Commit ec22f7dd authored by patrickdoc's avatar patrickdoc Committed by Ben Gamari

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
parent 12deb9a9
......@@ -145,6 +145,7 @@ _darcs/
/libraries/ghc-boot-th/GNUmakefile
/libraries/ghc-boot-th/ghc-boot-th.cabal
/libraries/ghc-boot-th/ghc.mk
/libraries/ghc-heap/ghc-heap.cabal
/libraries/ghci/GNUmakefile
/libraries/ghci/ghci.cabal
/libraries/ghci/ghc.mk
......
......@@ -64,6 +64,7 @@ Library
transformers == 0.5.*,
ghc-boot == @ProjectVersionMunged@,
ghc-boot-th == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
ghci == @ProjectVersionMunged@
if os(windows)
......@@ -643,5 +644,4 @@ Library
Debugger
Linker
RtClosureInspect
DebuggerUtils
GHCi
......@@ -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
......
......@@ -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
-- -----------------------------------------------------------------------------
......
{-# 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)
......@@ -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