1 -----------------------------------------------------------------------------
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
9 module RtClosureInspect(
11 cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
14 getClosureData, -- :: a -> IO Closure
15 Closure ( tipe, infoTable, ptrs, nonPtrs ),
16 getClosureType, -- :: a -> IO ClosureType
17 isConstr, -- :: ClosureType -> Bool
18 isIndirection, -- :: ClosureType -> Bool
19 getInfoTablePtr, -- :: a -> Ptr StgInfoTable
36 #include "HsVersions.h"
38 import ByteCodeItbls ( StgInfoTable )
39 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
40 import ByteCodeLink ( HValue )
41 import HscTypes ( HscEnv )
45 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
56 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
62 import Constants ( wORD_SIZE )
68 import GHC.Arr ( Array(..) )
69 import GHC.Ptr ( Ptr(..), castPtr )
71 import GHC.Int ( Int32(..), Int64(..) )
72 import GHC.Word ( Word32(..), Word64(..) )
76 import Data.Array.Base
77 import Data.List ( partition )
78 import Foreign.Storable
80 ---------------------------------------------
81 -- * A representation of semi evaluated Terms
82 ---------------------------------------------
84 A few examples in this representation:
86 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
88 > (('a',_,_),_,('b',_,_)) =
89 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
90 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]
92 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]
95 data Term = Term { ty :: Type
98 , subTerms :: [Term] }
103 | Suspension { ctype :: ClosureType
104 , mb_ty :: Maybe Type
106 , bound_to :: Maybe Name -- Useful for printing
111 isSuspension Suspension{} = True
112 isSuspension _ = False
116 termType t@(Suspension {}) = mb_ty t
117 termType t = Just$ ty t
119 isFullyEvaluatedTerm :: Term -> Bool
120 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
121 isFullyEvaluatedTerm Suspension {} = False
122 isFullyEvaluatedTerm Prim {} = True
124 instance Outputable (Term) where
125 ppr = head . customPrintTerm customPrintTermBase
127 -------------------------------------------------------------------------
128 -- Runtime Closure Datatype and functions for retrieving closure related stuff
129 -------------------------------------------------------------------------
130 data ClosureType = Constr
141 data Closure = Closure { tipe :: ClosureType
142 , infoTable :: StgInfoTable
143 , ptrs :: Array Int HValue
144 -- What would be the type here? HValue is ok? Should I build a Ptr?
145 , nonPtrs :: ByteArray#
148 instance Outputable ClosureType where
151 getInfoTablePtr :: a -> Ptr StgInfoTable
154 itbl_ptr -> castPtr ( Ptr itbl_ptr )
156 getClosureType :: a -> IO ClosureType
157 getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
159 #include "../includes/ClosureTypes.h"
166 getClosureData :: a -> IO Closure
167 getClosureData a = do
168 itbl <- peek (getInfoTablePtr a)
169 let tipe = readCType (BCI.tipe itbl)
170 case closurePayload# a of
172 let elems = BCI.ptrs itbl
173 ptrsList = Array 0 (fromIntegral$ elems) ptrs
174 in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
176 readCType :: Integral a => a -> ClosureType
178 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
179 | i >= FUN && i <= FUN_STATIC = Fun
180 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
181 | i == THUNK_SELECTOR = ThunkSelector
182 | i == BLACKHOLE = Blackhole
183 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
184 | fromIntegral i == aP_CODE = AP
185 | fromIntegral i == pAP_CODE = PAP
186 | otherwise = Other (fromIntegral i)
188 isConstr, isIndirection :: ClosureType -> Bool
189 isConstr Constr = True
192 isIndirection (Indirection _) = True
193 --isIndirection ThunkSelector = True
194 isIndirection _ = False
196 isFullyEvaluated :: a -> IO Bool
197 isFullyEvaluated a = do
198 closure <- getClosureData a
200 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
201 return$ and are_subs_evaluated
202 otherwise -> return False
203 where amapM f = sequence . amap' f
205 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
209 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
211 unsafeDeepSeq :: a -> b -> b
212 unsafeDeepSeq = unsafeDeepSeq1 2
213 where unsafeDeepSeq1 0 a b = seq a $! b
214 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
215 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
216 -- | unsafePerformIO (isFullyEvaluated a) = b
217 | otherwise = case unsafePerformIO (getClosureData a) of
218 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
219 where tipe = unsafePerformIO (getClosureType a)
221 isPointed :: Type -> Bool
222 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
225 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
227 extractUnboxed :: [Type] -> ByteArray# -> [String]
228 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
229 where helper :: [Type] -> Addr# -> [String]
231 | Just ( tycon,_) <- splitTyConApp_maybe t
232 = let (offset, txt) = decode tycon addr
233 (I# word_offset) = offset*wORD_SIZE
234 in txt : helper tt (plusAddr# addr word_offset)
236 = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
237 panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
239 decode :: TyCon -> Addr# -> (Int, String)
241 | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)
242 | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)
243 | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)
244 | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)
245 | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
246 | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)
247 | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
248 | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)
249 | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
250 | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses
251 | t == stablePtrPrimTyCon = (1, "<stablePtr>")
252 | t == stableNamePrimTyCon = (1, "<stableName>")
253 | t == statePrimTyCon = (1, "<statethread>")
254 | t == realWorldTyCon = (1, "<realworld>")
255 | t == threadIdPrimTyCon = (1, "<ThreadId>")
256 | t == weakPrimTyCon = (1, "<Weak>")
257 | t == arrayPrimTyCon = (1,"<array>")
258 | t == byteArrayPrimTyCon = (1,"<bytearray>")
259 | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
260 | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
261 | t == mutVarPrimTyCon= (1, "<mutVar>")
262 | t == mVarPrimTyCon = (1, "<mVar>")
263 | t == tVarPrimTyCon = (1, "<tVar>")
264 | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
265 -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
266 -- TODO: Improve the offset handling in decode (make it machine dependant)
268 -----------------------------------
269 -- * Traversals for Terms
270 -----------------------------------
272 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
273 , fPrim :: Type -> String -> a
274 , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
277 foldTerm :: TermFold a -> Term -> a
278 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
279 foldTerm tf (Prim ty v ) = fPrim tf ty v
280 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
282 idTermFold :: TermFold Term
283 idTermFold = TermFold {
286 fSuspension = Suspension
288 idTermFoldM :: Monad m => TermFold (m Term)
289 idTermFoldM = TermFold {
290 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
291 fPrim = (return.). Prim,
292 fSuspension = (((return.).).). Suspension
295 ----------------------------------
296 -- Pretty printing of terms
297 ----------------------------------
299 parensCond True = parens
300 parensCond False = id
304 printTerm :: Term -> SDoc
305 printTerm Prim{value=value} = text value
306 printTerm t@Term{} = printTerm1 0 t
307 printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
308 printTerm Suspension{mb_ty=Just ty, bound_to=Just n}
309 | Just _ <- splitFunTy_maybe ty = text "<function>"
310 | otherwise = parens$ ppr n <> text "::" <> ppr ty
312 printTerm1 p Term{dc=dc, subTerms=tt}
313 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
314 = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
315 <+> hsep (map (printTerm1 True) tt)
318 | otherwise = parensCond (p > app_prec)
319 (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
321 where fixity = undefined
323 printTerm1 _ t = printTerm t
325 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
326 customPrintTerm custom = let
327 -- go :: Monad m => Int -> Term -> m SDoc
328 go prec t@Term{subTerms=tt, dc=dc} = do
329 mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
330 case msum mb_customDocs of -- msum is in Maybe monad
331 Just doc -> return$ parensCond (prec>app_prec+1) doc
332 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
333 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
334 return$ parensCond (prec>app_prec+1)
335 (ppr dc <+> sep pprSubterms)
336 go _ t = return$ printTerm t
338 where fixity = undefined
340 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
341 customPrintTermBase showP =
343 test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
344 , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
345 , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
346 , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
347 -- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
348 , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
349 , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
350 , test isIntegerDC (coerceShow$ \(a::Integer)->a)
352 where test pred f t = if pred t then liftM Just (f t) else return Nothing
353 isIntegerDC Term{dc=dc} =
354 dataConName dc `elem` [ smallIntegerDataConName
355 , largeIntegerDataConName]
356 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
357 isDC a_dc Term{dc=dc} = a_dc == dc
358 coerceShow f = return . text . show . f . unsafeCoerce# . val
359 --TODO pprinting of list terms is not lazy
361 let elems = h : getListTerms t
362 isConsLast = isSuspension (last elems) &&
363 (mb_ty$ last elems) /= (termType h)
364 init <- mapM (showP 0) (init elems)
365 last0 <- showP 0 (last elems)
366 let last = case length elems of
368 _ | isConsLast -> text " | " <> last0
370 return$ brackets (hcat (punctuate comma init ++ [last]))
372 where Just a /= Just b = not (a `coreEqType` b)
374 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
375 getListTerms t@Term{subTerms=[]} = []
376 getListTerms t@Suspension{} = [t]
377 getListTerms t = pprPanic "getListTerms" (ppr t)
379 -----------------------------------
380 -- Type Reconstruction
381 -----------------------------------
383 -- The Type Reconstruction monad
386 runTR :: HscEnv -> TR Term -> IO Term
388 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
390 Nothing -> panic "Can't unify"
391 Just term -> return term
394 trIO = liftTcM . ioToTcRn
396 addConstraint :: TcType -> TcType -> TR ()
397 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
400 A parallel fold over two Type values,
401 compensating for missing newtypes on both sides.
402 This is necessary because newtypes are not present
403 in runtime, but since sometimes there is evidence
404 available we do our best to reconstruct them.
405 Evidence can come from DataCon signatures or
406 from compile-time type inference.
407 I am using the words congruence and rewriting
408 because what we are doing here is an approximation
409 of unification modulo a set of equations, which would
410 come from newtype definitions. These should be the
411 equality coercions seen in System Fc. Rewriting
412 is performed, taking those equations as rules,
413 before launching unification.
415 It doesn't make sense to rewrite everywhere,
416 or we would end up with all newtypes. So we rewrite
417 only in presence of evidence.
418 The lhs comes from the heap structure of ptrs,nptrs.
419 The rhs comes from a DataCon type signature.
420 Rewriting in the rhs is restricted to the result type.
422 Note that it is very tricky to make this 'rewriting'
423 work with the unification implemented by TcM, where
424 substitutions are 'inlined'. The order in which
425 constraints are unified is vital for this (or I am
428 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
429 congruenceNewtypes = go True
431 go rewriteRHS lhs rhs
432 -- TyVar lhs inductive case
433 | Just tv <- getTyVar_maybe lhs
434 = recoverM (return (lhs,rhs)) $ do
435 Indirect ty_v <- readMetaTyVar tv
436 (lhs', rhs') <- go rewriteRHS ty_v rhs
437 writeMutVar (metaTvRef tv) (Indirect lhs')
439 -- TyVar rhs inductive case
440 | Just tv <- getTyVar_maybe rhs
441 = recoverM (return (lhs,rhs)) $ do
442 Indirect ty_v <- readMetaTyVar tv
443 (lhs', rhs') <- go rewriteRHS lhs ty_v
444 writeMutVar (metaTvRef tv) (Indirect rhs')
446 -- FunTy inductive case
447 | Just (l1,l2) <- splitFunTy_maybe lhs
448 , Just (r1,r2) <- splitFunTy_maybe rhs
449 = do (l2',r2') <- go True l2 r2
450 (l1',r1') <- go False l1 r1
451 return (mkFunTy l1' l2', mkFunTy r1' r2')
452 -- TyconApp Inductive case; this is the interesting bit.
453 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
454 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
456 let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
457 then (tycon_r, rewrite tycon_r lhs)
458 else (tycon_l, args_l)
459 (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
460 then (tycon_l, rewrite tycon_l rhs)
461 else (tycon_r, args_r)
462 (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
463 return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
465 | otherwise = return (lhs,rhs)
467 where rewrite newtyped_tc lame_tipe
468 | (tvs, tipe) <- newTyConRep newtyped_tc
469 = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
470 Just subst -> substTys subst (map mkTyVarTy tvs)
471 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
473 newVar :: Kind -> TR TcTyVar
474 newVar = liftTcM . newFlexiTyVar
478 instScheme :: Type -> TR TcType
479 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
480 where fst3 (x,y,z) = x
483 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
484 cvObtainTerm hsc_env force mb_ty a =
485 -- Obtain the term and tidy the type before returning it
486 cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
488 tidyTypes = foldTerm idTermFold {
489 fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
490 fSuspension = \ct mb_ty hval n ->
491 Suspension ct (fmap tidy mb_ty) hval n
493 tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
496 mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
497 | (tv,v) <- zip alphaTyVars vars]
498 where vars = varSetElems$ tyVarsOfType ty
500 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
501 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
502 tv <- liftM mkTyVarTy (newVar argTypeKind)
503 when (isJust mb_ty) $
504 instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
508 ctype <- trIO$ getClosureType a
510 -- Thunks we may want to force
511 Thunk _ | force -> seq a $ go tv a
512 -- We always follow indirections
513 _ | isIndirection ctype -> do
514 clos <- trIO$ getClosureData a
515 (go tv $! (ptrs clos ! 0))
516 -- The interesting case
518 m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
520 Nothing -> panic "Can't find the DataCon for a term"
522 clos <- trIO$ getClosureData a
523 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
524 subTtypes = drop extra_args (dataConRepArgTys dc)
525 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
526 n_subtermsP= length subTtypesP
527 subTermTvs <- mapM (liftM mkTyVarTy . newVar ) (map typeKind subTtypesP)
528 baseType <- instScheme (dataConRepType dc)
529 let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
530 addConstraint myType baseType
531 subTermsP <- sequence [ extractSubterm i tv (ptrs clos)
532 | (i,tv) <- zip [extra_args..extra_args + n_subtermsP - 1]
534 let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
535 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
536 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
537 return (Term tv dc a subTerms)
538 -- The otherwise case: can be a Thunk,AP,PAP,etc.
540 return (Suspension ctype (Just tv) a Nothing)
542 -- Access the array of pointers and recurse down. Needs to be done with
543 -- care of no introducing a thunk! or go will fail to do its job
544 extractSubterm (I# i#) tv ptrs = case ptrs of
545 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
548 -- This is used to put together pointed and nonpointed subterms in the
550 reOrderTerms _ _ [] = []
551 reOrderTerms pointed unpointed (ty:tys)
552 | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
553 | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
555 zonkTerm :: Term -> TcM Term
556 zonkTerm = foldTerm idTermFoldM {
557 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
558 zonkTcType ty >>= \ty' ->
559 return (Term ty' dc v tt)
560 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
561 return (Suspension ct ty v b)}
564 -- Is this defined elsewhere?
565 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
566 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
569 Example of Type Reconstruction
570 --------------------------------
571 Suppose we have an existential type such as
573 data Opaque = forall a. Opaque a
575 And we have a term built as:
577 t = Opaque (map Just [[1,1],[2,2]])
579 The type of t as far as the typechecker goes is t :: Opaque
580 If we seq the head of t, we obtain:
586 t - O ( (_3::b) : (_4::[b]) )
590 t - O ( (Just (_5::c)) : (_4::[b]) )
592 At this point, we know that b = (Maybe c)
596 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
598 At this point, we know that c = [d]
602 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
604 At this point, we know that d = Integer
606 The fully reconstructed expressions, with propagation, would be:
608 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
609 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
610 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
613 For reference, the type of the thing inside the opaque is
614 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
616 NOTE: (Num t) contexts have been manually replaced by Integer for clarity