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 :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
319 customPrintTerm custom = let
320 -- go :: Monad m => Int -> Term -> m SDoc
321 go prec t@Term{subTerms=tt, dc=dc} = do
322 mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
323 case msum mb_customDocs of -- msum is in Maybe monad
324 Just doc -> return$ parensCond (prec>app_prec+1) doc
325 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
326 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
327 return$ parensCond (prec>app_prec+1)
328 (ppr dc <+> sep pprSubterms)
329 go _ t = return$ printTerm t
331 where fixity = undefined
333 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
334 customPrintTermBase showP =
336 test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
337 , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
338 , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
339 , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
340 -- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
341 , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
342 , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
343 , test isIntegerDC (coerceShow$ \(a::Integer)->a)
345 where test pred f t = if pred t then liftM Just (f t) else return Nothing
346 isIntegerDC Term{dc=dc} =
347 dataConName dc `elem` [ smallIntegerDataConName
348 , largeIntegerDataConName]
349 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
350 isDC a_dc Term{dc=dc} = a_dc == dc
351 coerceShow f = return . text . show . f . unsafeCoerce# . val
352 --TODO pprinting of list terms is not lazy
354 let elems = h : getListTerms t
355 isConsLast = isSuspension (last elems) &&
356 (mb_ty$ last elems) /= (termType h)
357 init <- mapM (showP 0) (init elems)
358 last0 <- showP 0 (last elems)
359 let last = case length elems of
361 _ | isConsLast -> text " | " <> last0
363 return$ brackets (hcat (punctuate comma init ++ [last]))
365 where Just a /= Just b = not (a `coreEqType` b)
367 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
368 getListTerms t@Term{subTerms=[]} = []
369 getListTerms t@Suspension{} = [t]
370 getListTerms t = pprPanic "getListTerms" (ppr t)
372 -----------------------------------
373 -- Type Reconstruction
374 -----------------------------------
376 -- The Type Reconstruction monad
379 runTR :: HscEnv -> TR Term -> IO Term
381 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
383 Nothing -> panic "Can't unify"
384 Just term -> return term
387 trIO = liftTcM . ioToTcRn
389 addConstraint :: TcType -> TcType -> TR ()
390 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
393 A parallel fold over two Type values,
394 compensating for missing newtypes on both sides.
395 This is necessary because newtypes are not present
396 in runtime, but since sometimes there is evidence
397 available we do our best to reconstruct them.
398 Evidence can come from DataCon signatures or
399 from compile-time type inference.
400 I am using the words congruence and rewriting
401 because what we are doing here is an approximation
402 of unification modulo a set of equations, which would
403 come from newtype definitions. These should be the
404 equality coercions seen in System Fc. Rewriting
405 is performed, taking those equations as rules,
406 before launching unification.
408 It doesn't make sense to rewrite everywhere,
409 or we would end up with all newtypes. So we rewrite
410 only in presence of evidence.
411 The lhs comes from the heap structure of ptrs,nptrs.
412 The rhs comes from a DataCon type signature.
413 Rewriting in the rhs is restricted to the result type.
415 Note that it is very tricky to make this 'rewriting'
416 work with the unification implemented by TcM, where
417 substitutions are 'inlined'. The order in which
418 constraints are unified is vital for this (or I am
421 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
422 congruenceNewtypes = go True
424 go rewriteRHS lhs rhs
425 -- TyVar lhs inductive case
426 | Just tv <- getTyVar_maybe lhs
427 = recoverM (return (lhs,rhs)) $ do
428 Indirect ty_v <- readMetaTyVar tv
429 (lhs', rhs') <- go rewriteRHS ty_v rhs
430 writeMutVar (metaTvRef tv) (Indirect lhs')
432 -- TyVar rhs inductive case
433 | Just tv <- getTyVar_maybe rhs
434 = recoverM (return (lhs,rhs)) $ do
435 Indirect ty_v <- readMetaTyVar tv
436 (lhs', rhs') <- go rewriteRHS lhs ty_v
437 writeMutVar (metaTvRef tv) (Indirect rhs')
439 -- FunTy inductive case
440 | Just (l1,l2) <- splitFunTy_maybe lhs
441 , Just (r1,r2) <- splitFunTy_maybe rhs
442 = do (l2',r2') <- go True l2 r2
443 (l1',r1') <- go False l1 r1
444 return (mkFunTy l1' l2', mkFunTy r1' r2')
445 -- TyconApp Inductive case; this is the interesting bit.
446 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
447 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
449 let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
450 then (tycon_r, rewrite tycon_r lhs)
451 else (tycon_l, args_l)
452 (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
453 then (tycon_l, rewrite tycon_l rhs)
454 else (tycon_r, args_r)
455 (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
456 return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
458 | otherwise = return (lhs,rhs)
460 where rewrite newtyped_tc lame_tipe
461 | (tvs, tipe) <- newTyConRep newtyped_tc
462 = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
463 Just subst -> substTys subst (map mkTyVarTy tvs)
464 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
466 newVar :: Kind -> TR TcTyVar
467 newVar = liftTcM . newFlexiTyVar
471 instScheme :: Type -> TR TcType
472 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
473 where fst3 (x,y,z) = x
476 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
477 cvObtainTerm hsc_env force mb_ty a = do
478 -- Obtain the term and tidy the type before returning it
479 term <- cvObtainTerm1 hsc_env force mb_ty a
480 return $ tidyTypes term
482 tidyTypes = foldTerm idTermFold {
483 fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
484 fSuspension = \ct mb_ty hval n ->
485 Suspension ct (fmap tidy mb_ty) hval n
487 tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
490 mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
491 | (tv,v) <- zip alphaTyVars vars]
492 where vars = varSetElems$ tyVarsOfType ty
494 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
495 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
496 tv <- liftM mkTyVarTy (newVar argTypeKind)
497 when (isJust mb_ty) $
498 instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
502 clos <- trIO $ getClosureData a
504 -- Thunks we may want to force
505 Thunk _ | force -> seq a $ go tv a
506 -- We always follow indirections
507 Indirection _ -> go tv $! (ptrs clos ! 0)
508 -- The interesting case
510 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
512 Nothing -> panic "Can't find the DataCon for a term"
514 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
515 subTtypes = drop extra_args (dataConRepArgTys dc)
516 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
517 n_subtermsP= length subTtypesP
518 subTermTvs <- mapM (liftM mkTyVarTy . newVar ) (map typeKind subTtypesP)
519 baseType <- instScheme (dataConRepType dc)
520 let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
521 addConstraint myType baseType
522 subTermsP <- sequence [ extractSubterm i tv (ptrs clos)
523 | (i,tv) <- zip [extra_args..extra_args + n_subtermsP - 1]
525 let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
526 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
527 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
528 return (Term tv dc a subTerms)
529 -- The otherwise case: can be a Thunk,AP,PAP,etc.
531 return (Suspension (tipe clos) (Just tv) a Nothing)
533 -- Access the array of pointers and recurse down. Needs to be done with
534 -- care of no introducing a thunk! or go will fail to do its job
535 extractSubterm (I# i#) tv ptrs = case ptrs of
536 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
539 -- This is used to put together pointed and nonpointed subterms in the
541 reOrderTerms _ _ [] = []
542 reOrderTerms pointed unpointed (ty:tys)
543 | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
544 | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
546 zonkTerm :: Term -> TcM Term
547 zonkTerm = foldTerm idTermFoldM {
548 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
549 zonkTcType ty >>= \ty' ->
550 return (Term ty' dc v tt)
551 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
552 return (Suspension ct ty v b)}
555 -- Is this defined elsewhere?
556 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
557 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
560 Example of Type Reconstruction
561 --------------------------------
562 Suppose we have an existential type such as
564 data Opaque = forall a. Opaque a
566 And we have a term built as:
568 t = Opaque (map Just [[1,1],[2,2]])
570 The type of t as far as the typechecker goes is t :: Opaque
571 If we seq the head of t, we obtain:
577 t - O ( (_3::b) : (_4::[b]) )
581 t - O ( (Just (_5::c)) : (_4::[b]) )
583 At this point, we know that b = (Maybe c)
587 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
589 At this point, we know that c = [d]
593 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
595 At this point, we know that d = Integer
597 The fully reconstructed expressions, with propagation, would be:
599 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
600 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
601 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
604 For reference, the type of the thing inside the opaque is
605 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
607 NOTE: (Num t) contexts have been manually replaced by Integer for clarity