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, infoPtr, ptrs, nonPtrs ),
16 isConstr, -- :: ClosureType -> Bool
17 isIndirection, -- :: ClosureType -> Bool
34 #include "HsVersions.h"
36 import ByteCodeItbls ( StgInfoTable )
37 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
38 import ByteCodeLink ( HValue )
39 import HscTypes ( HscEnv )
43 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
54 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
60 import Constants ( wORD_SIZE )
66 import GHC.Arr ( Array(..) )
67 import GHC.Ptr ( Ptr(..), castPtr )
69 import GHC.Int ( Int32(..), Int64(..) )
70 import GHC.Word ( Word32(..), Word64(..) )
74 import Data.Array.Base
75 import Data.List ( partition )
76 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
143 , infoTable :: StgInfoTable
144 , ptrs :: Array Int HValue
145 -- What would be the type here? HValue is ok? Should I build a Ptr?
146 , nonPtrs :: ByteArray#
149 instance Outputable ClosureType where
152 #include "../includes/ClosureTypes.h"
159 getClosureData :: a -> IO Closure
161 case unpackClosure# a of
162 (# iptr, ptrs, nptrs #) -> do
163 itbl <- peek (Ptr iptr)
164 let tipe = readCType (BCI.tipe itbl)
165 elems = BCI.ptrs itbl
166 ptrsList = Array 0 (fromIntegral$ elems) ptrs
167 ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
169 readCType :: Integral a => a -> ClosureType
171 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
172 | i >= FUN && i <= FUN_STATIC = Fun
173 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
174 | i == THUNK_SELECTOR = ThunkSelector
175 | i == BLACKHOLE = Blackhole
176 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
177 | fromIntegral i == aP_CODE = AP
178 | fromIntegral i == pAP_CODE = PAP
179 | otherwise = Other (fromIntegral i)
181 isConstr, isIndirection :: ClosureType -> Bool
182 isConstr Constr = True
185 isIndirection (Indirection _) = True
186 --isIndirection ThunkSelector = True
187 isIndirection _ = False
189 isFullyEvaluated :: a -> IO Bool
190 isFullyEvaluated a = do
191 closure <- getClosureData a
193 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
194 return$ and are_subs_evaluated
195 otherwise -> return False
196 where amapM f = sequence . amap' f
198 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
202 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
204 unsafeDeepSeq :: a -> b -> b
205 unsafeDeepSeq = unsafeDeepSeq1 2
206 where unsafeDeepSeq1 0 a b = seq a $! b
207 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
208 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
209 -- | unsafePerformIO (isFullyEvaluated a) = b
210 | otherwise = case unsafePerformIO (getClosureData a) of
211 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
212 where tipe = unsafePerformIO (getClosureType a)
214 isPointed :: Type -> Bool
215 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
218 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
220 extractUnboxed :: [Type] -> ByteArray# -> [String]
221 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
222 where helper :: [Type] -> Addr# -> [String]
224 | Just ( tycon,_) <- splitTyConApp_maybe t
225 = let (offset, txt) = decode tycon addr
226 (I# word_offset) = offset*wORD_SIZE
227 in txt : helper tt (plusAddr# addr word_offset)
229 = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
230 panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
232 decode :: TyCon -> Addr# -> (Int, String)
234 | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)
235 | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)
236 | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)
237 | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)
238 | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
239 | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)
240 | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
241 | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)
242 | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
243 | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses
244 | t == stablePtrPrimTyCon = (1, "<stablePtr>")
245 | t == stableNamePrimTyCon = (1, "<stableName>")
246 | t == statePrimTyCon = (1, "<statethread>")
247 | t == realWorldTyCon = (1, "<realworld>")
248 | t == threadIdPrimTyCon = (1, "<ThreadId>")
249 | t == weakPrimTyCon = (1, "<Weak>")
250 | t == arrayPrimTyCon = (1,"<array>")
251 | t == byteArrayPrimTyCon = (1,"<bytearray>")
252 | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
253 | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
254 | t == mutVarPrimTyCon= (1, "<mutVar>")
255 | t == mVarPrimTyCon = (1, "<mVar>")
256 | t == tVarPrimTyCon = (1, "<tVar>")
257 | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
258 -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
259 -- TODO: Improve the offset handling in decode (make it machine dependant)
261 -----------------------------------
262 -- * Traversals for Terms
263 -----------------------------------
265 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
266 , fPrim :: Type -> String -> a
267 , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
270 foldTerm :: TermFold a -> Term -> a
271 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
272 foldTerm tf (Prim ty v ) = fPrim tf ty v
273 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
275 idTermFold :: TermFold Term
276 idTermFold = TermFold {
279 fSuspension = Suspension
281 idTermFoldM :: Monad m => TermFold (m Term)
282 idTermFoldM = TermFold {
283 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
284 fPrim = (return.). Prim,
285 fSuspension = (((return.).).). Suspension
288 ----------------------------------
289 -- Pretty printing of terms
290 ----------------------------------
292 parensCond True = parens
293 parensCond False = id
297 printTerm :: Term -> SDoc
298 printTerm Prim{value=value} = text value
299 printTerm t@Term{} = printTerm1 0 t
300 printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
301 printTerm Suspension{mb_ty=Just ty, bound_to=Just n}
302 | Just _ <- splitFunTy_maybe ty = text "<function>"
303 | otherwise = parens$ ppr n <> text "::" <> ppr ty
305 printTerm1 p Term{dc=dc, subTerms=tt}
306 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
307 = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
308 <+> hsep (map (printTerm1 True) tt)
311 | otherwise = parensCond (p > app_prec)
312 (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
314 where fixity = undefined
316 printTerm1 _ t = printTerm t
318 customPrintTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
319 customPrintTerm custom = go 0 where
320 -- go :: Monad m => Int -> Term -> m SDoc
321 go prec t@Term{subTerms=tt, dc=dc} = do
322 let mb_customDocs = map ($t) (custom go) :: [m (Maybe SDoc)]
323 first_success <- firstJustM mb_customDocs
324 case first_success of
325 Just doc -> return$ parensCond (prec>app_prec+1) doc
326 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
327 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
328 return$ parensCond (prec>app_prec+1)
329 (ppr dc <+> sep pprSubterms)
330 go _ t = return$ printTerm t
331 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
332 firstJustM [] = return Nothing
334 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
335 customPrintTermBase showP =
337 test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
338 , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
339 , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
340 , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
341 -- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
342 , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
343 , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
344 , test isIntegerDC (coerceShow$ \(a::Integer)->a)
346 where test pred f t = if pred t then liftM Just (f t) else return Nothing
347 isIntegerDC Term{dc=dc} =
348 dataConName dc `elem` [ smallIntegerDataConName
349 , largeIntegerDataConName]
350 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
351 isDC a_dc Term{dc=dc} = a_dc == dc
352 coerceShow f = return . text . show . f . unsafeCoerce# . val
353 --TODO pprinting of list terms is not lazy
355 let elems = h : getListTerms t
356 isConsLast = isSuspension (last elems) &&
357 (mb_ty$ last elems) /= (termType h)
358 init <- mapM (showP 0) (init elems)
359 last0 <- showP 0 (last elems)
360 let last = case length elems of
362 _ | isConsLast -> text " | " <> last0
364 return$ brackets (hcat (punctuate comma init ++ [last]))
366 where Just a /= Just b = not (a `coreEqType` b)
368 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
369 getListTerms t@Term{subTerms=[]} = []
370 getListTerms t@Suspension{} = [t]
371 getListTerms t = pprPanic "getListTerms" (ppr t)
373 -----------------------------------
374 -- Type Reconstruction
375 -----------------------------------
377 -- The Type Reconstruction monad
380 runTR :: HscEnv -> TR Term -> IO Term
382 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
384 Nothing -> panic "Can't unify"
385 Just term -> return term
388 trIO = liftTcM . ioToTcRn
390 addConstraint :: TcType -> TcType -> TR ()
391 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
394 A parallel fold over two Type values,
395 compensating for missing newtypes on both sides.
396 This is necessary because newtypes are not present
397 in runtime, but since sometimes there is evidence
398 available we do our best to reconstruct them.
399 Evidence can come from DataCon signatures or
400 from compile-time type inference.
401 I am using the words congruence and rewriting
402 because what we are doing here is an approximation
403 of unification modulo a set of equations, which would
404 come from newtype definitions. These should be the
405 equality coercions seen in System Fc. Rewriting
406 is performed, taking those equations as rules,
407 before launching unification.
409 It doesn't make sense to rewrite everywhere,
410 or we would end up with all newtypes. So we rewrite
411 only in presence of evidence.
412 The lhs comes from the heap structure of ptrs,nptrs.
413 The rhs comes from a DataCon type signature.
414 Rewriting in the rhs is restricted to the result type.
416 Note that it is very tricky to make this 'rewriting'
417 work with the unification implemented by TcM, where
418 substitutions are 'inlined'. The order in which
419 constraints are unified is vital for this (or I am
422 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
423 congruenceNewtypes = go True
425 go rewriteRHS lhs rhs
426 -- TyVar lhs inductive case
427 | Just tv <- getTyVar_maybe lhs
428 = recoverM (return (lhs,rhs)) $ do
429 Indirect ty_v <- readMetaTyVar tv
430 (lhs', rhs') <- go rewriteRHS ty_v rhs
431 writeMutVar (metaTvRef tv) (Indirect lhs')
433 -- TyVar rhs inductive case
434 | Just tv <- getTyVar_maybe rhs
435 = recoverM (return (lhs,rhs)) $ do
436 Indirect ty_v <- readMetaTyVar tv
437 (lhs', rhs') <- go rewriteRHS lhs ty_v
438 writeMutVar (metaTvRef tv) (Indirect rhs')
440 -- FunTy inductive case
441 | Just (l1,l2) <- splitFunTy_maybe lhs
442 , Just (r1,r2) <- splitFunTy_maybe rhs
443 = do (l2',r2') <- go True l2 r2
444 (l1',r1') <- go False l1 r1
445 return (mkFunTy l1' l2', mkFunTy r1' r2')
446 -- TyconApp Inductive case; this is the interesting bit.
447 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
448 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
450 let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
451 then (tycon_r, rewrite tycon_r lhs)
452 else (tycon_l, args_l)
453 (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
454 then (tycon_l, rewrite tycon_l rhs)
455 else (tycon_r, args_r)
456 (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
457 return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
459 | otherwise = return (lhs,rhs)
461 where rewrite newtyped_tc lame_tipe
462 | (tvs, tipe) <- newTyConRep newtyped_tc
463 = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
464 Just subst -> substTys subst (map mkTyVarTy tvs)
465 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
467 newVar :: Kind -> TR TcTyVar
468 newVar = liftTcM . newFlexiTyVar
472 instScheme :: Type -> TR TcType
473 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
474 where fst3 (x,y,z) = x
477 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
478 cvObtainTerm hsc_env force mb_ty a = do
479 -- Obtain the term and tidy the type before returning it
480 term <- cvObtainTerm1 hsc_env force mb_ty a
481 return $ tidyTypes term
483 tidyTypes = foldTerm idTermFold {
484 fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
485 fSuspension = \ct mb_ty hval n ->
486 Suspension ct (fmap tidy mb_ty) hval n
488 tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
491 mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
492 | (tv,v) <- zip alphaTyVars vars]
493 where vars = varSetElems$ tyVarsOfType ty
495 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
496 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
497 tv <- liftM mkTyVarTy (newVar argTypeKind)
498 when (isJust mb_ty) $
499 instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
503 clos <- trIO $ getClosureData a
505 -- Thunks we may want to force
506 Thunk _ | force -> seq a $ go tv a
507 -- We always follow indirections
508 Indirection _ -> go tv $! (ptrs clos ! 0)
509 -- The interesting case
511 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
513 Nothing -> panic "Can't find the DataCon for a term"
515 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
516 subTtypes = drop extra_args (dataConRepArgTys dc)
517 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
518 n_subtermsP= length subTtypesP
519 subTermTvs <- mapM (liftM mkTyVarTy . newVar ) (map typeKind subTtypesP)
520 baseType <- instScheme (dataConRepType dc)
521 let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
522 addConstraint myType baseType
523 subTermsP <- sequence [ extractSubterm i tv (ptrs clos)
524 | (i,tv) <- zip [extra_args..extra_args + n_subtermsP - 1]
526 let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
527 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
528 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
529 return (Term tv dc a subTerms)
530 -- The otherwise case: can be a Thunk,AP,PAP,etc.
532 return (Suspension (tipe clos) (Just tv) a Nothing)
534 -- Access the array of pointers and recurse down. Needs to be done with
535 -- care of no introducing a thunk! or go will fail to do its job
536 extractSubterm (I# i#) tv ptrs = case ptrs of
537 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
540 -- This is used to put together pointed and nonpointed subterms in the
542 reOrderTerms _ _ [] = []
543 reOrderTerms pointed unpointed (ty:tys)
544 | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
545 | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
547 zonkTerm :: Term -> TcM Term
548 zonkTerm = foldTerm idTermFoldM {
549 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
550 zonkTcType ty >>= \ty' ->
551 return (Term ty' dc v tt)
552 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
553 return (Suspension ct ty v b)}
556 -- Is this defined elsewhere?
557 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
558 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
561 Example of Type Reconstruction
562 --------------------------------
563 Suppose we have an existential type such as
565 data Opaque = forall a. Opaque a
567 And we have a term built as:
569 t = Opaque (map Just [[1,1],[2,2]])
571 The type of t as far as the typechecker goes is t :: Opaque
572 If we seq the head of t, we obtain:
578 t - O ( (_3::b) : (_4::[b]) )
582 t - O ( (Just (_5::c)) : (_4::[b]) )
584 At this point, we know that b = (Maybe c)
588 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
590 At this point, we know that c = [d]
594 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
596 At this point, we know that d = Integer
598 The fully reconstructed expressions, with propagation, would be:
600 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
601 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
602 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
605 For reference, the type of the thing inside the opaque is
606 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
608 NOTE: (Num t) contexts have been manually replaced by Integer for clarity