1 -----------------------------------------------------------------------------
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
9 module RtClosureInspect(
10 cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
15 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
16 isFullyEvaluated, isFullyEvaluatedTerm,
17 termType, mapTermType, termTyVars,
18 foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
19 pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
23 Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
26 #include "HsVersions.h"
28 import ByteCodeItbls ( StgInfoTable )
29 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
35 import qualified Unify as U
36 import TypeRep -- I know I know, this is cheating
53 import Outputable as Ppr
55 import Constants ( wORD_SIZE )
56 import GHC.Arr ( Array(..) )
58 import GHC.IO ( IO(..) )
60 import StaticFlags( opt_PprStyle_Debug )
63 import Data.Array.Base
66 import qualified Data.Sequence as Seq
68 import Data.Sequence (viewl, ViewL(..))
69 import Foreign hiding (unsafePerformIO)
70 import System.IO.Unsafe
72 ---------------------------------------------
73 -- * A representation of semi evaluated Terms
74 ---------------------------------------------
76 data Term = Term { ty :: RttiType
77 , dc :: Either String DataCon
78 -- Carries a text representation if the datacon is
79 -- not exported by the .hi file, which is the case
80 -- for private constructors in -O0 compiled libraries
82 , subTerms :: [Term] }
84 | Prim { ty :: RttiType
87 | Suspension { ctype :: ClosureType
90 , bound_to :: Maybe Name -- Useful for printing
92 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
93 -- newtype constructors. A NewtypeWrap is just a
94 -- made-up tag saying "heads up, there used to be
95 -- a newtype constructor here".
97 , dc :: Either String DataCon
98 , wrapped_term :: Term }
99 | RefWrap { -- The contents of a reference
101 , wrapped_term :: Term }
103 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
106 isSuspension Suspension{} = True
107 isSuspension _ = False
110 isNewtypeWrap NewtypeWrap{} = True
111 isNewtypeWrap _ = False
113 isFun Suspension{ctype=Fun} = True
116 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
119 termType :: Term -> RttiType
122 isFullyEvaluatedTerm :: Term -> Bool
123 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
124 isFullyEvaluatedTerm Prim {} = True
125 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
126 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
127 isFullyEvaluatedTerm _ = False
129 instance Outputable (Term) where
130 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
131 | otherwise = panic "Outputable Term instance"
133 -------------------------------------------------------------------------
134 -- Runtime Closure Datatype and functions for retrieving closure related stuff
135 -------------------------------------------------------------------------
136 data ClosureType = Constr
149 data Closure = Closure { tipe :: ClosureType
151 , infoTable :: StgInfoTable
152 , ptrs :: Array Int HValue
156 instance Outputable ClosureType where
159 #include "../includes/rts/storage/ClosureTypes.h"
161 aP_CODE, pAP_CODE :: Int
167 getClosureData :: a -> IO Closure
169 case unpackClosure# a of
170 (# iptr, ptrs, nptrs #) -> do
172 | ghciTablesNextToCode =
175 -- the info pointer we get back from unpackClosure#
176 -- is to the beginning of the standard info table,
177 -- but the Storable instance for info tables takes
178 -- into account the extra entry pointer when
179 -- !ghciTablesNextToCode, so we must adjust here:
180 Ptr iptr `plusPtr` negate wORD_SIZE
182 let tipe = readCType (BCI.tipe itbl)
183 elems = fromIntegral (BCI.ptrs itbl)
184 ptrsList = Array 0 (elems - 1) elems ptrs
185 nptrs_data = [W# (indexWordArray# nptrs i)
186 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
187 ASSERT(elems >= 0) return ()
189 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
191 readCType :: Integral a => a -> ClosureType
193 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
194 | i >= FUN && i <= FUN_STATIC = Fun
195 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
196 | i == THUNK_SELECTOR = ThunkSelector
197 | i == BLACKHOLE = Blackhole
198 | i >= IND && i <= IND_STATIC = Indirection i'
201 | i' == pAP_CODE = PAP
202 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
203 | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
204 | otherwise = Other i'
205 where i' = fromIntegral i
207 isConstr, isIndirection, isThunk :: ClosureType -> Bool
208 isConstr Constr = True
211 isIndirection (Indirection _) = True
212 isIndirection _ = False
214 isThunk (Thunk _) = True
215 isThunk ThunkSelector = True
219 isFullyEvaluated :: a -> IO Bool
220 isFullyEvaluated a = do
221 closure <- getClosureData a
223 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
224 return$ and are_subs_evaluated
226 where amapM f = sequence . amap' f
228 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
230 unsafeDeepSeq :: a -> b -> b
231 unsafeDeepSeq = unsafeDeepSeq1 2
232 where unsafeDeepSeq1 0 a b = seq a $! b
233 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
234 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
235 -- | unsafePerformIO (isFullyEvaluated a) = b
236 | otherwise = case unsafePerformIO (getClosureData a) of
237 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
238 where tipe = unsafePerformIO (getClosureType a)
241 -----------------------------------
242 -- * Traversals for Terms
243 -----------------------------------
244 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
246 data TermFold a = TermFold { fTerm :: TermProcessor a a
247 , fPrim :: RttiType -> [Word] -> a
248 , fSuspension :: ClosureType -> RttiType -> HValue
250 , fNewtypeWrap :: RttiType -> Either String DataCon
252 , fRefWrap :: RttiType -> a -> a
257 TermFoldM {fTermM :: TermProcessor a (m a)
258 , fPrimM :: RttiType -> [Word] -> m a
259 , fSuspensionM :: ClosureType -> RttiType -> HValue
261 , fNewtypeWrapM :: RttiType -> Either String DataCon
263 , fRefWrapM :: RttiType -> a -> m a
266 foldTerm :: TermFold a -> Term -> a
267 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
268 foldTerm tf (Prim ty v ) = fPrim tf ty v
269 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
270 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
271 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
274 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
275 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
276 foldTermM tf (Prim ty v ) = fPrimM tf ty v
277 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
278 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
279 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
281 idTermFold :: TermFold Term
282 idTermFold = TermFold {
285 fSuspension = Suspension,
286 fNewtypeWrap = NewtypeWrap,
290 mapTermType :: (RttiType -> Type) -> Term -> Term
291 mapTermType f = foldTerm idTermFold {
292 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
293 fSuspension = \ct ty hval n ->
294 Suspension ct (f ty) hval n,
295 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
296 fRefWrap = \ty t -> RefWrap (f ty) t}
298 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
299 mapTermTypeM f = foldTermM TermFoldM {
300 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
301 fPrimM = (return.) . Prim,
302 fSuspensionM = \ct ty hval n ->
303 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
304 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
305 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
307 termTyVars :: Term -> TyVarSet
308 termTyVars = foldTerm TermFold {
309 fTerm = \ty _ _ tt ->
310 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
311 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
312 fPrim = \ _ _ -> emptyVarEnv,
313 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
314 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
315 where concatVarEnv = foldr plusVarEnv emptyVarEnv
317 ----------------------------------
318 -- Pretty printing of terms
319 ----------------------------------
321 type Precedence = Int
322 type TermPrinter = Precedence -> Term -> SDoc
323 type TermPrinterM m = Precedence -> Term -> m SDoc
325 app_prec,cons_prec, max_prec ::Int
328 cons_prec = 5 -- TODO Extract this info from GHC itself
330 pprTerm :: TermPrinter -> TermPrinter
331 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
332 pprTerm _ _ _ = panic "pprTerm"
334 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
335 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
337 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
338 tt_docs <- mapM (y app_prec) tt
339 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
341 ppr_termM y p Term{dc=Right dc, subTerms=tt}
342 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
343 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
344 <+> hsep (map (ppr_term1 True) tt)
345 -} -- TODO Printing infix constructors properly
346 | null sub_terms_to_show
349 = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
350 ; return $ cparen (p >= app_prec) $
351 sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
353 sub_terms_to_show -- Don't show the dictionary arguments to
354 -- constructors unless -dppr-debug is on
355 | opt_PprStyle_Debug = tt
356 | otherwise = dropList (dataConTheta dc) tt
358 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
359 ppr_termM y p RefWrap{wrapped_term=t} = do
360 contents <- y app_prec t
361 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
362 -- The constructor name is wired in here ^^^ for the sake of simplicity.
363 -- I don't think mutvars are going to change in a near future.
364 -- In any case this is solely a presentation matter: MutVar# is
365 -- a datatype with no constructors, implemented by the RTS
366 -- (hence there is no way to obtain a datacon and print it).
367 ppr_termM _ _ t = ppr_termM1 t
370 ppr_termM1 :: Monad m => Term -> m SDoc
371 ppr_termM1 Prim{value=words, ty=ty} =
372 return$ text$ repPrim (tyConAppTyCon ty) words
373 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
374 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
375 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
376 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
377 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
378 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
379 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
380 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
382 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
383 | Just (tc,_) <- tcSplitTyConApp_maybe ty
384 , ASSERT(isNewTyCon tc) True
385 , Just new_dc <- tyConSingleDataCon_maybe tc = do
386 real_term <- y max_prec t
387 return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
388 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
390 -------------------------------------------------------
391 -- Custom Term Pretty Printers
392 -------------------------------------------------------
394 -- We can want to customize the representation of a
395 -- term depending on its type.
396 -- However, note that custom printers have to work with
397 -- type representations, instead of directly with types.
398 -- We cannot use type classes here, unless we employ some
399 -- typerep trickery (e.g. Weirich's RepLib tricks),
400 -- which I didn't. Therefore, this code replicates a lot
401 -- of what type classes provide for free.
403 type CustomTermPrinter m = TermPrinterM m
404 -> [Precedence -> Term -> (m (Maybe SDoc))]
406 -- | Takes a list of custom printers with a explicit recursion knot and a term,
407 -- and returns the output of the first succesful printer, or the default printer
408 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
409 cPprTerm printers_ = go 0 where
410 printers = printers_ go
412 let default_ = Just `liftM` pprTermM go prec t
413 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
414 Just doc <- firstJustM mb_customDocs
415 return$ cparen (prec>app_prec+1) doc
417 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
418 firstJustM [] = return Nothing
420 -- Default set of custom printers. Note that the recursion knot is explicit
421 cPprTermBase :: forall m. Monad m => CustomTermPrinter m
423 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
426 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
428 , ifTerm (isTyCon intTyCon . ty) ppr_int
429 , ifTerm (isTyCon charTyCon . ty) ppr_char
430 , ifTerm (isTyCon floatTyCon . ty) ppr_float
431 , ifTerm (isTyCon doubleTyCon . ty) ppr_double
432 , ifTerm (isIntegerTy . ty) ppr_integer
435 ifTerm :: (Term -> Bool)
436 -> (Precedence -> Term -> m SDoc)
437 -> Precedence -> Term -> m (Maybe SDoc)
438 ifTerm pred f prec t@Term{}
439 | pred t = Just `liftM` f prec t
440 ifTerm _ _ _ _ = return Nothing
442 isTupleTy ty = fromMaybe False $ do
443 (tc,_) <- tcSplitTyConApp_maybe ty
444 return (isBoxedTupleTyCon tc)
446 isTyCon a_tc ty = fromMaybe False $ do
447 (tc,_) <- tcSplitTyConApp_maybe ty
450 isIntegerTy ty = fromMaybe False $ do
451 (tc,_) <- tcSplitTyConApp_maybe ty
452 return (tyConName tc == integerTyConName)
454 ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
455 :: Precedence -> Term -> m SDoc
456 ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
457 ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
458 ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
459 ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
460 ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
462 --Note pprinting of list terms is not lazy
463 ppr_list :: Precedence -> Term -> m SDoc
464 ppr_list p (Term{subTerms=[h,t]}) = do
465 let elems = h : getListTerms t
466 isConsLast = not(termType(last elems) `eqType` termType h)
467 is_string = all (isCharTy . ty) elems
469 print_elems <- mapM (y cons_prec) elems
471 then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
473 then return $ cparen (p >= cons_prec)
475 $ punctuate (space<>colon) print_elems
476 else return $ brackets
478 $ punctuate comma print_elems
480 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
481 getListTerms Term{subTerms=[]} = []
482 getListTerms t@Suspension{} = [t]
483 getListTerms t = pprPanic "getListTerms" (ppr t)
484 ppr_list _ _ = panic "doList"
487 repPrim :: TyCon -> [Word] -> String
488 repPrim t = rep where
490 | t == charPrimTyCon = show (build x :: Char)
491 | t == intPrimTyCon = show (build x :: Int)
492 | t == wordPrimTyCon = show (build x :: Word)
493 | t == floatPrimTyCon = show (build x :: Float)
494 | t == doublePrimTyCon = show (build x :: Double)
495 | t == int32PrimTyCon = show (build x :: Int32)
496 | t == word32PrimTyCon = show (build x :: Word32)
497 | t == int64PrimTyCon = show (build x :: Int64)
498 | t == word64PrimTyCon = show (build x :: Word64)
499 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
500 | t == stablePtrPrimTyCon = "<stablePtr>"
501 | t == stableNamePrimTyCon = "<stableName>"
502 | t == statePrimTyCon = "<statethread>"
503 | t == realWorldTyCon = "<realworld>"
504 | t == threadIdPrimTyCon = "<ThreadId>"
505 | t == weakPrimTyCon = "<Weak>"
506 | t == arrayPrimTyCon = "<array>"
507 | t == byteArrayPrimTyCon = "<bytearray>"
508 | t == mutableArrayPrimTyCon = "<mutableArray>"
509 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
510 | t == mutVarPrimTyCon= "<mutVar>"
511 | t == mVarPrimTyCon = "<mVar>"
512 | t == tVarPrimTyCon = "<tVar>"
513 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
514 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
515 -- This ^^^ relies on the representation of Haskell heap values being
516 -- the same as in a C array.
518 -----------------------------------
519 -- Type Reconstruction
520 -----------------------------------
522 Type Reconstruction is type inference done on heap closures.
523 The algorithm walks the heap generating a set of equations, which
524 are solved with syntactic unification.
525 A type reconstruction equation looks like:
527 <datacon reptype> = <actual heap contents>
529 The full equation set is generated by traversing all the subterms, starting
532 The only difficult part is that newtypes are only found in the lhs of equations.
533 Right hand sides are missing them. We can either (a) drop them from the lhs, or
534 (b) reconstruct them in the rhs when possible.
536 The function congruenceNewtypes takes a shot at (b)
540 -- A (non-mutable) tau type containing
541 -- existentially quantified tyvars.
542 -- (since GHC type language currently does not support
543 -- existentials, we leave these variables unquantified)
546 -- An incomplete type as stored in GHCi:
547 -- no polymorphism: no quantifiers & all tyvars are skolem.
551 -- The Type Reconstruction monad
552 --------------------------------
555 runTR :: HscEnv -> TR a -> IO a
556 runTR hsc_env thing = do
557 mb_val <- runTR_maybe hsc_env thing
559 Nothing -> error "unable to :print the term"
562 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
563 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
565 traceTR :: SDoc -> TR ()
566 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
569 -- Semantically different to recoverM in TcRnMonad
570 -- recoverM retains the errors in the first action,
571 -- whereas recoverTc here does not
572 recoverTR :: TR a -> TR a -> TR a
573 recoverTR recover thing = do
574 (_,mb_res) <- tryTcErrs thing
577 Just res -> return res
580 trIO = liftTcM . liftIO
582 liftTcM :: TcM a -> TR a
585 newVar :: Kind -> TR TcType
586 newVar = liftTcM . newFlexiTyVarTy
588 instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
589 -- Instantiate fresh mutable type variables from some TyVars
590 -- This function preserves the print-name, which helps error messages
591 instTyVars = liftTcM . tcInstTyVars
593 type RttiInstantiation = [(TcTyVar, TyVar)]
594 -- Associates the typechecker-world meta type variables
595 -- (which are mutable and may be refined), to their
596 -- debugger-world RuntimeUnk counterparts.
597 -- If the TcTyVar has not been refined by the runtime type
598 -- elaboration, then we want to turn it back into the
599 -- original RuntimeUnk
601 -- | Returns the instantiated type scheme ty', and the
602 -- mapping from new (instantiated) -to- old (skolem) type variables
603 instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
605 = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
606 ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
607 ; return (substTy subst ty, rtti_inst) }
609 applyRevSubst :: RttiInstantiation -> TR ()
610 -- Apply the *reverse* substitution in-place to any un-filled-in
611 -- meta tyvars. This recovers the original debugger-world variable
612 -- unless it has been refined by new information from the heap
613 applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
615 do_pair (tc_tv, rtti_tv)
616 = do { tc_ty <- zonkTcTyVar tc_tv
617 ; case tcGetTyVar_maybe tc_ty of
618 Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
621 -- Adds a constraint of the form t1 == t2
622 -- t1 is expected to come from walking the heap
623 -- t2 is expected to come from a datacon signature
624 -- Before unification, congruenceNewtypes needs to
626 addConstraint :: TcType -> TcType -> TR ()
627 addConstraint actual expected = do
628 traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
629 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
630 text "with", ppr expected]) $
631 do { (ty1, ty2) <- congruenceNewtypes actual expected
632 ; _ <- captureConstraints $ unifyType ty1 ty2
634 -- TOMDO: what about the coercion?
635 -- we should consider family instances
638 -- Type & Term reconstruction
639 ------------------------------
640 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
641 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
642 -- we quantify existential tyvars as universal,
643 -- as this is needed to be able to manipulate
645 let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
646 sigma_old_ty = mkForAllTys old_tvs old_tau
647 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
651 term <- go max_depth sigma_old_ty sigma_old_ty hval
652 term' <- zonkTerm term
653 return $ fixFunDictionaries $ expandNewtypes term'
655 (old_ty', rev_subst) <- instScheme quant_old_ty
656 my_ty <- newVar argTypeKind
657 when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
658 addConstraint my_ty old_ty')
659 term <- go max_depth my_ty sigma_old_ty hval
660 new_ty <- zonkTcType (termType term)
661 if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
663 traceTR (text "check2 passed")
664 addConstraint new_ty old_ty'
665 applyRevSubst rev_subst
666 zterm' <- zonkTerm term
667 return ((fixFunDictionaries . expandNewtypes) zterm')
669 traceTR (text "check2 failed" <+> parens
670 (ppr term <+> text "::" <+> ppr new_ty))
671 -- we have unsound types. Replace constructor types in
672 -- subterms with tyvars
673 zterm' <- mapTermTypeM
674 (\ty -> case tcSplitTyConApp_maybe ty of
675 Just (tc, _:_) | tc /= funTyCon
676 -> newVar argTypeKind
680 traceTR (text "Term reconstruction completed." $$
681 text "Term obtained: " <> ppr term $$
682 text "Type obtained: " <> ppr (termType term))
686 go :: Int -> Type -> Type -> HValue -> TcM Term
687 -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
689 go max_depth _ _ _ | seq max_depth False = undefined
690 go 0 my_ty _old_ty a = do
691 traceTR (text "Gave up reconstructing a term after" <>
692 int max_depth <> text " steps")
693 clos <- trIO $ getClosureData a
694 return (Suspension (tipe clos) my_ty a Nothing)
695 go max_depth my_ty old_ty a = do
696 let monomorphic = not(isTyVarTy my_ty)
697 -- This ^^^ is a convention. The ancestor tests for
698 -- monomorphism and passes a type instead of a tv
699 clos <- trIO $ getClosureData a
701 -- Thunks we may want to force
702 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
703 seq a (go (pred max_depth) my_ty old_ty a)
704 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
705 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
706 -- showing '_' which is what we want.
707 Blackhole -> do traceTR (text "Following a BLACKHOLE")
708 appArr (go max_depth my_ty old_ty) (ptrs clos) 0
709 -- We always follow indirections
710 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
711 go max_depth my_ty old_ty $! (ptrs clos ! 0)
712 -- We also follow references
713 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
715 -- Deal with the MutVar# primitive
716 -- It does not have a constructor at all,
717 -- so we simulate the following one
718 -- MutVar# :: contents_ty -> MutVar# s contents_ty
719 traceTR (text "Following a MutVar")
720 contents_tv <- newVar liftedTypeKind
721 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
722 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
723 (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
724 contents_ty (mkTyConApp tycon [world,contents_ty])
725 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
726 x <- go (pred max_depth) contents_tv contents_ty contents
727 return (RefWrap my_ty x)
729 -- The interesting case
731 traceTR (text "entering a constructor " <>
733 then parens (text "already monomorphic: " <> ppr my_ty)
735 Right dcname <- dataConInfoPtrToName (infoPtr clos)
736 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
738 Nothing -> do -- This can happen for private constructors compiled -O0
739 -- where the .hi descriptor does not export them
740 -- In such case, we return a best approximation:
741 -- ignore the unpointed args, and recover the pointeds
742 -- This preserves laziness, and should be safe.
743 traceTR (text "Nothing" <+> ppr dcname)
744 let tag = showSDoc (ppr dcname)
745 vars <- replicateM (length$ elems$ ptrs clos)
746 (newVar liftedTypeKind)
747 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
748 | (i, tv) <- zip [0..] vars]
749 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
751 traceTR (text "Just" <+> ppr dc)
752 subTtypes <- getDataConArgTys dc my_ty
753 let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
754 subTermsP <- sequence
755 [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
756 | (i,ty) <- zip [0..] subTtypesP]
757 let unboxeds = extractUnboxed subTtypesNP clos
758 subTermsNP = zipWith Prim subTtypesNP unboxeds
759 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
760 return (Term my_ty (Right dc) a subTerms)
762 -- The otherwise case: can be a Thunk,AP,PAP,etc.
764 return (Suspension tipe_clos my_ty a Nothing)
766 -- put together pointed and nonpointed subterms in the
768 reOrderTerms _ _ [] = []
769 reOrderTerms pointed unpointed (ty:tys)
770 | isPtrType ty = ASSERT2(not(null pointed)
771 , ptext (sLit "reOrderTerms") $$
772 (ppr pointed $$ ppr unpointed))
773 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
774 | otherwise = ASSERT2(not(null unpointed)
775 , ptext (sLit "reOrderTerms") $$
776 (ppr pointed $$ ppr unpointed))
777 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
779 -- insert NewtypeWraps around newtypes
780 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
782 | Just (tc, args) <- tcSplitTyConApp_maybe ty
784 , wrapped_type <- newTyConInstRhs tc args
785 , Just dc' <- tyConSingleDataCon_maybe tc
786 , t' <- worker wrapped_type dc hval tt
787 = NewtypeWrap ty (Right dc') t'
788 | otherwise = Term ty dc hval tt
791 -- Avoid returning types where predicates have been expanded to dictionaries.
792 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
793 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
794 | otherwise = Suspension ct ty hval n
797 -- Fast, breadth-first Type reconstruction
798 ------------------------------------------
799 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
800 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
801 traceTR (text "RTTI started with initial type " <> ppr old_ty)
802 let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
807 (old_ty', rev_subst) <- instScheme sigma_old_ty
808 my_ty <- newVar argTypeKind
809 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
810 addConstraint my_ty old_ty')
811 search (isMonomorphic `fmap` zonkTcType my_ty)
813 (Seq.singleton (my_ty, hval))
815 new_ty <- zonkTcType my_ty
816 if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
818 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
819 addConstraint my_ty old_ty'
820 applyRevSubst rev_subst
822 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
824 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
827 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
828 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
829 int max_depth <> text " steps")
830 search stop expand l d =
833 x :< xx -> unlessM stop $ do
835 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
837 -- returns unification tasks,since we are going to want a breadth-first search
838 go :: Type -> HValue -> TR [(Type, HValue)]
840 traceTR (text "go" <+> ppr my_ty)
841 clos <- trIO $ getClosureData a
843 Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
844 Indirection _ -> go my_ty $! (ptrs clos ! 0)
846 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
847 tv' <- newVar liftedTypeKind
848 world <- newVar liftedTypeKind
849 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
850 return [(tv', contents)]
852 Right dcname <- dataConInfoPtrToName (infoPtr clos)
853 traceTR (text "Constr1" <+> ppr dcname)
854 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
857 -- TODO: Check this case
858 forM [0..length (elems $ ptrs clos)] $ \i -> do
859 tv <- newVar liftedTypeKind
860 return$ appArr (\e->(tv,e)) (ptrs clos) i
863 arg_tys <- getDataConArgTys dc my_ty
864 traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
865 return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
866 | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
869 -- Compute the difference between a base type and the type found by RTTI
870 -- improveType <base_type> <rtti_type>
871 -- The types can contain skolem type variables, which need to be treated as normal vars.
872 -- In particular, we want them to unify with things.
873 improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
874 improveRTTIType _ base_ty new_ty
875 = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
877 getDataConArgTys :: DataCon -> Type -> TR [Type]
878 -- Given the result type ty of a constructor application (D a b c :: ty)
879 -- return the types of the arguments. This is RTTI-land, so 'ty' might
880 -- not be fully known. Moreover, the arg types might involve existentials;
881 -- if so, make up fresh RTTI type variables for them
882 getDataConArgTys dc con_app_ty
883 = do { (_, ex_tys, _) <- instTyVars ex_tvs
884 ; let rep_con_app_ty = repType con_app_ty
885 ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
886 Just (tc, ty_args) | dataConTyCon dc == tc
887 -> ASSERT( univ_tvs `equalLength` ty_args)
889 _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs
890 ; let res_ty = substTy subst (dataConOrigResTy dc)
891 ; addConstraint rep_con_app_ty res_ty
893 -- It is necessary to check dataConTyCon dc == tc
894 -- because it may be the case that tc is a recursive
895 -- newtype and tcSplitTyConApp has not removed it. In
896 -- that case, we happily give up and don't match
897 ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
898 ; return (substTys subst (dataConRepArgTys dc)) }
900 univ_tvs = dataConUnivTyVars dc
901 ex_tvs = dataConExTyVars dc
903 isPtrType :: Type -> Bool
904 isPtrType ty = case typePrimRep ty of
911 This is not formalized anywhere, so hold to your seats!
912 RTTI in the presence of newtypes can be a tricky and unsound business.
916 Suppose we are doing RTTI for a partially evaluated
917 closure t, the real type of which is t :: MkT Int, for
919 newtype MkT a = MkT [Maybe a]
921 The table below shows the results of RTTI and the improvement
922 calculated for different combinations of evaluatedness and :type t.
923 Regard the two first columns as input and the next two as output.
925 # | t | :type t | rtti(t) | improv. | result
926 ------------------------------------------------------------
927 1 | _ | t b | a | none | OK
928 2 | _ | MkT b | a | none | OK
929 3 | _ | t Int | a | none | OK
931 If t is not evaluated at *all*, we are safe.
933 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
934 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
935 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
937 If a is a minimal whnf, we run into trouble. Note that
938 row 5 above does newtype enrichment on the ty_rtty parameter.
940 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
943 8 | (Just _:_)| MkT b | MkT a | none | OK
944 9 | (Just _:_)| t Int | FAIL | none | OK
946 And if t is any more evaluated than whnf, we are still in trouble.
947 Because constraints are solved in top-down order, when we reach the
948 Maybe subterm what we got is already unsound. This explains why the
949 row 9 fails to complete.
951 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
952 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
954 We can undo the failure in row 9 by leaving out the constraint
955 coming from the type signature of t (i.e., the 2nd column).
956 Note that this type information is still used
957 to calculate the improvement. But we fail
958 when trying to calculate the improvement, as there is no unifier for
959 t Int = [Maybe a] or t Int = [Maybe Int].
962 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
964 # | t | :type t | rtti(t) | improvement | result
965 ---------------------------------------------------------------------
966 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
967 | | | | b = Maybe a |
971 Consider a function obtainType that takes a value and a type and produces
972 the Term representation and a substitution (the improvement).
973 Assume an auxiliar rtti' function which does the actual job if recovering
974 the type, but which may produce a false type.
978 rtti' :: a -> IO Type -- Does not use the static type information
980 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
981 obtainType v old_ty = do
983 if monomorphic rtti_ty || (check rtti_ty old_ty)
986 where check rtti_ty old_ty = check1 rtti_ty &&
987 check2 rtti_ty old_ty
989 check1 :: Type -> Bool
990 check2 :: Type -> Type -> Bool
992 Now, if rtti' returns a monomorphic type, we are safe.
993 If that is not the case, then we consider two conditions.
996 1. To prevent the class of unsoundness displayed by
997 rows 4 and 7 in the example: no higher kind tyvars
1004 2. To prevent the class of unsoundness shown by row 6,
1005 the rtti type should be structurally more
1006 defined than the old type we are comparing it to.
1007 check2 :: NewType -> OldType -> Bool
1010 check2 [a] (t Int) = False
1011 check2 [a] (t a) = False -- By check1 we never reach this equation
1012 check2 [Int] a = True
1013 check2 [Int] (t Int) = True
1014 check2 [Maybe a] (t Int) = False
1015 check2 [Maybe Int] (t Int) = True
1016 check2 (Maybe [a]) (m [Int]) = False
1017 check2 (Maybe [Int]) (m [Int]) = True
1021 check1 :: QuantifiedType -> Bool
1022 check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
1024 isHigherKind = not . null . fst . splitKindFunTys
1026 check2 :: QuantifiedType -> QuantifiedType -> Bool
1027 check2 (_, rtti_ty) (_, old_ty)
1028 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1030 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1031 -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
1032 _ | Just _ <- splitAppTy_maybe old_ty
1033 -> isMonomorphicOnNonPhantomArgs rtti_ty
1037 -- Dealing with newtypes
1038 --------------------------
1040 congruenceNewtypes does a parallel fold over two Type values,
1041 compensating for missing newtypes on both sides.
1042 This is necessary because newtypes are not present
1043 in runtime, but sometimes there is evidence available.
1044 Evidence can come from DataCon signatures or
1045 from compile-time type inference.
1046 What we are doing here is an approximation
1047 of unification modulo a set of equations derived
1048 from newtype definitions. These equations should be the
1049 same as the equality coercions generated for newtypes
1050 in System Fc. The idea is to perform a sort of rewriting,
1051 taking those equations as rules, before launching unification.
1053 The caller must ensure the following.
1054 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1055 The 2nd type (rhs) comes from a DataCon type signature.
1056 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1057 in both types, but in the rhs it is restricted to the result type.
1059 Note that it is very tricky to make this 'rewriting'
1060 work with the unification implemented by TcM, where
1061 substitutions are operationally inlined. The order in which
1062 constraints are unified is vital as we cannot modify
1063 anything that has been touched by a previous unification step.
1064 Therefore, congruenceNewtypes is sound only if the types
1065 recovered by the RTTI mechanism are unified Top-Down.
1067 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1068 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1071 -- TyVar lhs inductive case
1072 | Just tv <- getTyVar_maybe l
1075 = recoverTR (return r) $ do
1076 Indirect ty_v <- readMetaTyVar tv
1077 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1078 ppr tv, equals, ppr ty_v]
1080 -- FunTy inductive case
1081 | Just (l1,l2) <- splitFunTy_maybe l
1082 , Just (r1,r2) <- splitFunTy_maybe r
1083 = do r2' <- go l2 r2
1085 return (mkFunTy r1' r2')
1086 -- TyconApp Inductive case; this is the interesting bit.
1087 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1088 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1089 , tycon_l /= tycon_r
1092 | otherwise = return r
1094 where upgrade :: TyCon -> Type -> TR Type
1095 upgrade new_tycon ty
1096 | not (isNewTyCon new_tycon) = do
1097 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1098 ppr new_tycon <> text " for " <> ppr ty)
1101 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1102 text " in presence of newtype evidence " <> ppr new_tycon)
1103 (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
1104 let ty' = mkTyConApp new_tycon vars
1105 _ <- liftTcM (unifyType ty (repType ty'))
1106 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1110 zonkTerm :: Term -> TcM Term
1111 zonkTerm = foldTermM (TermFoldM
1112 { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
1113 return (Term ty' dc v tt)
1114 , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
1115 return (Suspension ct ty v b)
1116 , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
1117 return$ NewtypeWrap ty' dc t
1118 , fRefWrapM = \ty t -> return RefWrap `ap`
1119 zonkRttiType ty `ap` return t
1120 , fPrimM = (return.) . Prim })
1122 zonkRttiType :: TcType -> TcM Type
1123 -- Zonk the type, replacing any unbound Meta tyvars
1124 -- by skolems, safely out of Meta-tyvar-land
1125 zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
1127 zonk_unbound_meta tv
1128 = ASSERT( isTcTyVar tv )
1129 do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
1130 -- This is where RuntimeUnks are born:
1131 -- otherwise-unconstrained unification variables are
1132 -- turned into RuntimeUnks as they leave the
1133 -- typechecker's monad
1134 ; return (mkTyVarTy tv') }
1136 --------------------------------------------------------------------------------
1137 -- Restore Class predicates out of a representation type
1138 dictsView :: Type -> Type
1139 -- dictsView ty = ty
1140 dictsView (FunTy (TyConApp tc_dict args) ty)
1141 | Just c <- tyConClass_maybe tc_dict
1142 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1144 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1145 , Just c <- tyConClass_maybe tc_dict
1146 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1150 -- Use only for RTTI types
1151 isMonomorphic :: RttiType -> Bool
1152 isMonomorphic ty = noExistentials && noUniversals
1153 where (tvs, _, ty') = tcSplitSigmaTy ty
1154 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1155 noUniversals = null tvs
1157 -- Use only for RTTI types
1158 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1159 isMonomorphicOnNonPhantomArgs ty
1160 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1161 , phantom_vars <- tyConPhantomTyVars tc
1162 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1163 , tyv `notElem` phantom_vars]
1164 = all isMonomorphicOnNonPhantomArgs concrete_args
1165 | Just (ty1, ty2) <- splitFunTy_maybe ty
1166 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1167 | otherwise = isMonomorphic ty
1169 tyConPhantomTyVars :: TyCon -> [TyVar]
1170 tyConPhantomTyVars tc
1172 , Just dcs <- tyConDataCons_maybe tc
1173 , dc_vars <- concatMap dataConUnivTyVars dcs
1174 = tyConTyVars tc \\ dc_vars
1175 tyConPhantomTyVars _ = []
1177 type QuantifiedType = ([TyVar], Type) -- Make the free type variables explicit
1179 quantifyType :: Type -> QuantifiedType
1180 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1181 quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
1183 unlessM :: Monad m => m Bool -> m () -> m ()
1184 unlessM condM acc = condM >>= \c -> unless c acc
1187 -- Strict application of f at index i
1188 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1189 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1190 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1191 case indexArray# ptrs# i# of
1194 amap' :: (t -> b) -> Array Int t -> [b]
1195 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1196 where g (I# i#) = case indexArray# arr# i# of
1199 extractUnboxed :: [Type] -> Closure -> [[Word]]
1200 extractUnboxed tt clos = go tt (nonPtrs clos)
1201 where sizeofType t = primRepSizeW (typePrimRep t)
1204 | (x, rest) <- splitAt (sizeofType t) xx