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
22 getClosureData, -- :: a -> IO Closure
23 Closure ( tipe, infoTable, ptrs, nonPtrs ),
24 getClosureType, -- :: a -> IO ClosureType
25 isConstr, -- :: ClosureType -> Bool
26 isIndirection, -- :: ClosureType -> Bool
27 getInfoTablePtr, -- :: a -> Ptr StgInfoTable
46 #include "HsVersions.h"
48 import ByteCodeItbls ( StgInfoTable )
49 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
50 import ByteCodeLink ( HValue )
51 import HscTypes ( HscEnv )
55 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
66 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
72 import Constants ( wORD_SIZE )
78 import GHC.Arr ( Array(..) )
79 import GHC.Ptr ( Ptr(..), castPtr )
81 import GHC.Int ( Int32(..), Int64(..) )
82 import GHC.Word ( Word32(..), Word64(..) )
86 import Data.Array.Base
87 import Data.List ( partition )
88 import Foreign.Storable
90 ---------------------------------------------
91 -- * A representation of semi evaluated Terms
92 ---------------------------------------------
94 A few examples in this representation:
96 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
98 > (('a',_,_),_,('b',_,_)) =
99 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
100 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]
102 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]
105 data Term = Term { ty :: Type
108 , subTerms :: [Term] }
113 | Suspension { ctype :: ClosureType
114 , mb_ty :: Maybe Type
116 , bound_to :: Maybe Name -- Useful for printing
121 isSuspension Suspension{} = True
122 isSuspension _ = False
126 termType t@(Suspension {}) = mb_ty t
127 termType t = Just$ ty t
129 isFullyEvaluatedTerm :: Term -> Bool
130 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
131 isFullyEvaluatedTerm Suspension {} = False
132 isFullyEvaluatedTerm Prim {} = True
134 instance Outputable (Term) where
135 ppr = head . customPrintTerm customPrintTermBase
137 -------------------------------------------------------------------------
138 -- Runtime Closure Datatype and functions for retrieving closure related stuff
139 -------------------------------------------------------------------------
140 data ClosureType = Constr
151 data Closure = Closure { tipe :: ClosureType
152 , infoTable :: StgInfoTable
153 , ptrs :: Array Int HValue
154 -- What would be the type here? HValue is ok? Should I build a Ptr?
155 , nonPtrs :: ByteArray#
158 instance Outputable ClosureType where
161 getInfoTablePtr :: a -> Ptr StgInfoTable
164 itbl_ptr -> castPtr ( Ptr itbl_ptr )
166 getClosureType :: a -> IO ClosureType
167 getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
169 #include "../includes/ClosureTypes.h"
176 getClosureData :: a -> IO Closure
177 getClosureData a = do
178 itbl <- peek (getInfoTablePtr a)
179 let tipe = readCType (BCI.tipe itbl)
180 case closurePayload# a of
182 let elems = BCI.ptrs itbl
183 ptrsList = Array 0 (fromIntegral$ elems) ptrs
184 in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
186 readCType :: Integral a => a -> ClosureType
188 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
189 | i >= FUN && i <= FUN_STATIC = Fun
190 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
191 | i == THUNK_SELECTOR = ThunkSelector
192 | i == BLACKHOLE = Blackhole
193 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
194 | fromIntegral i == aP_CODE = AP
195 | fromIntegral i == pAP_CODE = PAP
196 | otherwise = Other (fromIntegral i)
198 isConstr, isIndirection :: ClosureType -> Bool
199 isConstr Constr = True
202 isIndirection (Indirection _) = True
203 --isIndirection ThunkSelector = True
204 isIndirection _ = False
206 isFullyEvaluated :: a -> IO Bool
207 isFullyEvaluated a = do
208 closure <- getClosureData a
210 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
211 return$ and are_subs_evaluated
212 otherwise -> return False
213 where amapM f = sequence . amap' f
215 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
219 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
221 unsafeDeepSeq :: a -> b -> b
222 unsafeDeepSeq = unsafeDeepSeq1 2
223 where unsafeDeepSeq1 0 a b = seq a $! b
224 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
225 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
226 -- | unsafePerformIO (isFullyEvaluated a) = b
227 | otherwise = case unsafePerformIO (getClosureData a) of
228 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
229 where tipe = unsafePerformIO (getClosureType a)
231 isPointed :: Type -> Bool
232 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
235 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
237 extractUnboxed :: [Type] -> ByteArray# -> [String]
238 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
239 where helper :: [Type] -> Addr# -> [String]
241 | Just ( tycon,_) <- splitTyConApp_maybe t
242 = let (offset, txt) = decode tycon addr
243 (I# word_offset) = offset*wORD_SIZE
244 in txt : helper tt (plusAddr# addr word_offset)
246 = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
247 panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
249 decode :: TyCon -> Addr# -> (Int, String)
251 | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)
252 | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)
253 | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)
254 | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)
255 | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
256 | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)
257 | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
258 | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)
259 | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
260 | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses
261 | t == stablePtrPrimTyCon = (1, "<stablePtr>")
262 | t == stableNamePrimTyCon = (1, "<stableName>")
263 | t == statePrimTyCon = (1, "<statethread>")
264 | t == realWorldTyCon = (1, "<realworld>")
265 | t == threadIdPrimTyCon = (1, "<ThreadId>")
266 | t == weakPrimTyCon = (1, "<Weak>")
267 | t == arrayPrimTyCon = (1,"<array>")
268 | t == byteArrayPrimTyCon = (1,"<bytearray>")
269 | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
270 | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
271 | t == mutVarPrimTyCon= (1, "<mutVar>")
272 | t == mVarPrimTyCon = (1, "<mVar>")
273 | t == tVarPrimTyCon = (1, "<tVar>")
274 | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
275 -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
276 -- TODO: Improve the offset handling in decode (make it machine dependant)
278 -----------------------------------
279 -- * Traversals for Terms
280 -----------------------------------
282 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
283 , fPrim :: Type -> String -> a
284 , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
287 foldTerm :: TermFold a -> Term -> a
288 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
289 foldTerm tf (Prim ty v ) = fPrim tf ty v
290 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
292 idTermFold :: TermFold Term
293 idTermFold = TermFold {
296 fSuspension = Suspension
298 idTermFoldM :: Monad m => TermFold (m Term)
299 idTermFoldM = TermFold {
300 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
301 fPrim = (return.). Prim,
302 fSuspension = (((return.).).). Suspension
305 ----------------------------------
306 -- Pretty printing of terms
307 ----------------------------------
309 parensCond True = parens
310 parensCond False = id
314 printTerm :: Term -> SDoc
315 printTerm Prim{value=value} = text value
316 printTerm t@Term{} = printTerm1 0 t
317 printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
318 printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =
319 parens$ ppr n <> text "::" <> ppr ty
321 printTerm1 p Term{dc=dc, subTerms=tt}
322 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
323 = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
324 <+> hsep (map (printTerm1 True) tt)
327 | otherwise = parensCond (p > app_prec)
328 (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
330 where fixity = undefined
332 printTerm1 _ t = printTerm t
334 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
335 customPrintTerm custom = let
336 -- go :: Monad m => Int -> Term -> m SDoc
337 go prec t@Term{subTerms=tt, dc=dc} = do
338 mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
339 case msum mb_customDocs of -- msum is in Maybe monad
340 Just doc -> return$ parensCond (prec>app_prec+1) doc
341 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
342 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
343 return$ parensCond (prec>app_prec+1)
344 (ppr dc <+> sep pprSubterms)
345 go _ t = return$ printTerm t
347 where fixity = undefined
349 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
350 customPrintTermBase showP =
352 test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
353 , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
354 , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
355 , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
356 -- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
357 , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
358 , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
359 , test isIntegerDC (coerceShow$ \(a::Integer)->a)
361 where test pred f t = if pred t then liftM Just (f t) else return Nothing
362 isIntegerDC Term{dc=dc} =
363 dataConName dc `elem` [ smallIntegerDataConName
364 , largeIntegerDataConName]
365 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
366 isDC a_dc Term{dc=dc} = a_dc == dc
367 coerceShow f = return . text . show . f . unsafeCoerce# . val
368 --TODO pprinting of list terms is not lazy
370 let elems = h : getListTerms t
371 isConsLast = isSuspension (last elems) &&
372 (mb_ty$ last elems) /= (termType h)
373 init <- mapM (showP 0) (init elems)
374 last0 <- showP 0 (last elems)
375 let last = case length elems of
377 _ | isConsLast -> text " | " <> last0
379 return$ brackets (hcat (punctuate comma init ++ [last]))
381 where Just a /= Just b = not (a `coreEqType` b)
383 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
384 getListTerms t@Term{subTerms=[]} = []
385 getListTerms t@Suspension{} = [t]
386 getListTerms t = pprPanic "getListTerms" (ppr t)
388 -----------------------------------
389 -- Type Reconstruction
390 -----------------------------------
392 -- The Type Reconstruction monad
395 runTR :: HscEnv -> TR Term -> IO Term
397 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
399 Nothing -> panic "Can't unify"
400 Just term -> return term
403 trIO = liftTcM . ioToTcRn
405 addConstraint :: TcType -> TcType -> TR ()
406 addConstraint t1 t2 = congruenceNewtypes t1 t2 >> unifyType t1 t2
408 -- A parallel fold over a Type value, replacing
409 -- in the right side reptypes for newtypes as found in the lhs
410 -- Sadly it doesn't cover all the possibilities. It does not always manage
411 -- to recover the highest level type. See test print016 for an example
412 -- This is used for approximating a unification over types modulo newtypes that recovers
413 -- the most concrete, with-newtypes type
414 congruenceNewtypes :: TcType -> TcType -> TcM TcType
415 congruenceNewtypes lhs rhs
416 -- | pprTrace "Congruence" (ppr lhs $$ ppr rhs) False = undefined
417 -- We have a tctyvar at the other side
418 | Just tv <- getTyVar_maybe rhs
419 -- , trace "congruence, entering tyvar" True
420 = recoverM (return rhs) $ do
421 Indirect ty_v <- readMetaTyVar tv
422 newtyped_tytv <- congruenceNewtypes lhs ty_v
423 writeMutVar (metaTvRef tv) (Indirect newtyped_tytv)
425 -- We have a function type: go on inductively
426 | Just (r1,r2) <- splitFunTy_maybe rhs
427 , Just (l1,l2) <- splitFunTy_maybe lhs
428 = liftM2 mkFunTy ( congruenceNewtypes l1 r1)
429 (congruenceNewtypes l2 r2)
430 -- There is a newtype at the top level tycon and we can manage it
431 | Just (tycon, args) <- splitNewTyConApp_maybe lhs
433 , (tvs, realtipe) <- newTyConRep tycon
434 = case tcUnifyTys (const BindMe) [realtipe] [rhs] of
436 let tvs' = substTys subst (map mkTyVarTy tvs) in
437 liftM (mkTyConApp tycon) (zipWithM congruenceNewtypes args tvs')
438 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
440 -- We have a TyconApp: go on inductively
441 | Just (tycon, args) <- splitNewTyConApp_maybe lhs
442 , Just (tycon_v, args_v) <- splitNewTyConApp_maybe rhs
443 = liftM (mkTyConApp tycon_v) (zipWithM congruenceNewtypes args args_v)
445 | otherwise = return rhs
448 newVar :: Kind -> TR TcTyVar
449 newVar = liftTcM . newFlexiTyVar
453 instScheme :: Type -> TR TcType
454 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
455 where fst3 (x,y,z) = x
458 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
459 cvObtainTerm hsc_env force mb_ty a =
460 -- Obtain the term and tidy the type before returning it
461 cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
463 tidyTypes = foldTerm idTermFold {
464 fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
465 fSuspension = \ct mb_ty hval n ->
466 Suspension ct (fmap tidy mb_ty) hval n
468 tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
471 mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
472 | (tv,v) <- zip alphaTyVars vars]
473 where vars = varSetElems$ tyVarsOfType ty
475 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
476 cvObtainTerm1 hsc_env force mb_ty hval
477 | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval
478 | Just ty <- mb_ty = runTR hsc_env $ do
479 term <- go argTypeKind hval
480 ty' <- instScheme (sigmaType ty)
481 addConstraint ty' (fromMaybe (error "by definition")
486 ctype <- trIO$ getClosureType a
488 -- Thunks we may want to force
489 Thunk _ | force -> seq a $ go k a
490 -- We always follow indirections
491 _ | isIndirection ctype
493 clos <- trIO$ getClosureData a
494 -- dflags <- getSessionDynFlags session
495 -- debugTraceMsg dflags 2 (text "Following an indirection")
496 go k $! (ptrs clos ! 0)
497 -- The interesting case
499 m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
501 Nothing -> panic "Can't find the DataCon for a term"
503 clos <- trIO$ getClosureData a
504 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
505 subTtypes = drop extra_args (dataConRepArgTys dc)
506 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
508 subTermsP <- mapM (\i->extractSubterm i (ptrs clos)
509 (subTtypesP!!(i-extra_args)))
510 [extra_args..extra_args + length subTtypesP - 1]
511 let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
512 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
513 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
514 resType <- liftM mkTyVarTy (newVar k)
515 baseType <- instScheme (dataConRepType dc)
516 let myType = mkFunTys (map (fromMaybe (error "cvObtainTerm1") . termType)
519 addConstraint baseType myType
520 return (Term resType dc a subTerms)
521 -- The otherwise case: can be a Thunk,AP,PAP,etc.
523 x <- liftM mkTyVarTy (newVar k)
524 return (Suspension ctype (Just x) a Nothing)
526 -- Access the array of pointers and recurse down. Needs to be done with
527 -- care of no introducing a thunk! or go will fail to do its job
528 extractSubterm (I# i#) ptrs ty = case ptrs of
529 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
530 (# e #) -> go (typeKind ty) e
532 -- This is used to put together pointed and nonpointed subterms in the
534 reOrderTerms _ _ [] = []
535 reOrderTerms pointed unpointed (ty:tys)
536 | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
537 | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
539 zonkTerm :: Term -> TcM Term
540 zonkTerm = foldTerm idTermFoldM {
541 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
542 zonkTcType ty >>= \ty' ->
543 return (Term ty' dc v tt)
544 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
545 return (Suspension ct ty v b)}
548 -- Is this defined elsewhere?
549 -- Find all free tyvars and insert the appropiate ForAll.
550 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
553 Example of Type Reconstruction
554 --------------------------------
555 Suppose we have an existential type such as
557 data Opaque = forall a. Opaque a
559 And we have a term built as:
561 t = Opaque (map Just [[1,1],[2,2]])
563 The type of t as far as the typechecker goes is t :: Opaque
564 If we seq the head of t, we obtain:
570 t - O ( (_3::b) : (_4::[b]) )
574 t - O ( (Just (_5::c)) : (_4::[b]) )
576 At this point, we know that b = (Maybe c)
580 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
582 At this point, we know that c = [d]
586 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
588 At this point, we know that d = Integer
590 The fully reconstructed expressions, with propagation, would be:
592 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
593 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
594 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
597 For reference, the type of the thing inside the opaque is
598 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
600 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
603 --------------------------------------------------------------------
604 -- The DataConEnv is used to store the addresses of datacons loaded
605 -- via the dynamic linker
606 --------------------------------------------------------------------
608 type DataConEnv = AddressEnv StgInfoTable
610 -- Note that this AddressEnv and DataConEnv I wrote trying to follow
611 -- conventions in ghc, but probably they make not much sense.
613 newtype AddressEnv a = AE {aenv:: FiniteMap (Ptr a) Name}
614 deriving (Outputable)
616 emptyAddressEnv = AE emptyFM
618 extendAddressEnvList :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a
619 elemAddressEnv :: Ptr a -> AddressEnv a -> Bool
620 delFromAddressEnv :: AddressEnv a -> Ptr a -> AddressEnv a
621 nullAddressEnv :: AddressEnv a -> Bool
622 lookupAddressEnv :: AddressEnv a -> Ptr a -> Maybe Name
624 extendAddressEnvList (AE env) = AE . addListToFM env
625 elemAddressEnv ptr (AE env) = ptr `elemFM` env
626 delFromAddressEnv (AE env) = AE . delFromFM env
627 nullAddressEnv = isEmptyFM . aenv
628 lookupAddressEnv (AE env) = lookupFM env
631 instance Outputable (Ptr a) where