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
23 Closure ( tipe, infoTable, ptrs, nonPtrs ),
44 #include "HsVersions.h"
46 import ByteCodeItbls ( StgInfoTable )
47 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
48 import ByteCodeLink ( HValue )
49 import HscTypes ( HscEnv )
53 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
65 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
71 import Constants ( wORD_SIZE )
77 import GHC.Arr ( Array(..) )
78 import GHC.Ptr ( Ptr(..), castPtr )
80 import GHC.Int ( Int32(..), Int64(..) )
81 import GHC.Word ( Word32(..), Word64(..) )
85 import Data.Array.Base
86 import Data.List ( partition )
87 import Foreign.Storable
89 ---------------------------------------------
90 -- * A representation of semi evaluated Terms
91 ---------------------------------------------
93 A few examples in this representation:
95 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
97 > (('a',_,_),_,('b',_,_)) =
98 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
99 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]
101 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]
104 data Term = Term { ty :: Type
107 , subTerms :: [Term] }
112 | Suspension { ctype :: ClosureType
113 , mb_ty :: Maybe Type
115 , bound_to :: Maybe Name -- Useful for printing
120 isSuspension Suspension{} = True
121 isSuspension _ = False
125 termType t@(Suspension {}) = mb_ty t
126 termType t = Just$ ty t
128 instance Outputable (Term) where
129 ppr = head . customPrintTerm customPrintTermBase
131 -------------------------------------------------------------------------
132 -- Runtime Closure Datatype and functions for retrieving closure related stuff
133 -------------------------------------------------------------------------
134 data ClosureType = Constr
145 data Closure = Closure { tipe :: ClosureType
146 , infoTable :: StgInfoTable
147 , ptrs :: Array Int HValue
148 -- What would be the type here? HValue is ok? Should I build a Ptr?
149 , nonPtrs :: ByteArray#
152 instance Outputable ClosureType where
155 getInfoTablePtr :: a -> Ptr StgInfoTable
158 itbl_ptr -> castPtr ( Ptr itbl_ptr )
160 getClosureType :: a -> IO ClosureType
161 getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
163 #include "../includes/ClosureTypes.h"
170 getClosureData :: a -> IO Closure
171 getClosureData a = do
172 itbl <- peek (getInfoTablePtr a)
173 let tipe = readCType (BCI.tipe itbl)
174 case closurePayload# a of
176 let elems = BCI.ptrs itbl
177 ptrsList = Array 0 (fromIntegral$ elems) ptrs
178 in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
180 readCType :: Integral a => a -> ClosureType
182 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
183 | i >= FUN && i <= FUN_STATIC = Fun
184 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
185 | i == THUNK_SELECTOR = ThunkSelector
186 | i == BLACKHOLE = Blackhole
187 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
188 | fromIntegral i == aP_CODE = AP
189 | fromIntegral i == pAP_CODE = PAP
190 | otherwise = Other (fromIntegral i)
192 isConstr, isIndirection :: ClosureType -> Bool
193 isConstr Constr = True
196 isIndirection (Indirection _) = True
197 --isIndirection ThunkSelector = True
198 isIndirection _ = False
200 isFullyEvaluated :: a -> IO Bool
201 isFullyEvaluated a = do
202 closure <- getClosureData a
204 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
205 return$ and are_subs_evaluated
206 otherwise -> return False
207 where amapM f = sequence . amap' f
209 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
213 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
215 unsafeDeepSeq :: a -> b -> b
216 unsafeDeepSeq = unsafeDeepSeq1 2
217 where unsafeDeepSeq1 0 a b = seq a $! b
218 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
219 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
220 -- | unsafePerformIO (isFullyEvaluated a) = b
221 | otherwise = case unsafePerformIO (getClosureData a) of
222 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
223 where tipe = unsafePerformIO (getClosureType a)
225 isPointed :: Type -> Bool
226 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
229 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
231 extractUnboxed :: [Type] -> ByteArray# -> [String]
232 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
233 where helper :: [Type] -> Addr# -> [String]
235 | Just ( tycon,_) <- splitTyConApp_maybe t
236 = let (offset, txt) = decode tycon addr
237 (I# word_offset) = offset*wORD_SIZE
238 in txt : helper tt (plusAddr# addr word_offset)
240 = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
241 panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
243 decode :: TyCon -> Addr# -> (Int, String)
245 | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)
246 | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)
247 | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)
248 | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)
249 | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
250 | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)
251 | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
252 | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)
253 | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
254 | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses
255 | t == stablePtrPrimTyCon = (1, "<stablePtr>")
256 | t == stableNamePrimTyCon = (1, "<stableName>")
257 | t == statePrimTyCon = (1, "<statethread>")
258 | t == realWorldTyCon = (1, "<realworld>")
259 | t == threadIdPrimTyCon = (1, "<ThreadId>")
260 | t == weakPrimTyCon = (1, "<Weak>")
261 | t == arrayPrimTyCon = (1,"<array>")
262 | t == byteArrayPrimTyCon = (1,"<bytearray>")
263 | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
264 | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
265 | t == mutVarPrimTyCon= (1, "<mutVar>")
266 | t == mVarPrimTyCon = (1, "<mVar>")
267 | t == tVarPrimTyCon = (1, "<tVar>")
268 | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
269 -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
270 -- TODO: Improve the offset handling in decode (make it machine dependant)
272 -----------------------------------
273 -- Boilerplate Fold code for Term
274 -----------------------------------
276 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
277 , fPrim :: Type -> String -> a
278 , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
281 foldTerm :: TermFold a -> Term -> a
282 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
283 foldTerm tf (Prim ty v ) = fPrim tf ty v
284 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
286 idTermFold :: TermFold Term
287 idTermFold = TermFold {
290 fSuspension = Suspension
292 idTermFoldM :: Monad m => TermFold (m Term)
293 idTermFoldM = TermFold {
294 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
295 fPrim = (return.). Prim,
296 fSuspension = (((return.).).). Suspension
299 ----------------------------------
300 -- Pretty printing of terms
301 ----------------------------------
303 parensCond True = parens
304 parensCond False = id
308 printTerm :: Term -> SDoc
309 printTerm Prim{value=value} = text value
310 printTerm t@Term{} = printTerm1 0 t
311 printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
312 printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =
313 parens$ ppr n <> text "::" <> ppr ty
315 printTerm1 p Term{dc=dc, subTerms=tt}
316 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
317 = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
318 <+> hsep (map (printTerm1 True) tt)
321 | otherwise = parensCond (p > app_prec)
322 (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
324 where fixity = undefined
326 printTerm1 _ t = printTerm t
328 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
329 customPrintTerm custom = let
330 -- go :: Monad m => Int -> Term -> m SDoc
331 go prec t@Term{subTerms=tt, dc=dc} = do
332 mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
333 case msum mb_customDocs of -- msum is in Maybe monad
334 Just doc -> return$ parensCond (prec>app_prec+1) doc
335 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
336 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
337 return$ parensCond (prec>app_prec+1)
338 (ppr dc <+> sep pprSubterms)
339 go _ t = return$ printTerm t
341 where fixity = undefined
343 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
344 customPrintTermBase showP =
346 test isTupleDC (liftM (parens . cat . punctuate comma) . mapM (showP 0) . subTerms)
347 , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
348 , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
349 , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
350 -- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
351 , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
352 , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
353 , test isIntegerDC (coerceShow$ \(a::Integer)->a)
355 where test pred f t = if pred t then liftM Just (f t) else return Nothing
356 isIntegerDC Term{dc=dc} =
357 dataConName dc `elem` [ smallIntegerDataConName
358 , largeIntegerDataConName]
359 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
360 isDC a_dc Term{dc=dc} = a_dc == dc
361 coerceShow f Term{val=val} = return . text . show . f . unsafeCoerce# $ val
362 --TODO pprinting of list terms is not lazy
364 let elems = h : getListTerms t
365 isConsLast = isSuspension (last elems) &&
366 (mb_ty$ last elems) /= (termType h)
367 init <- mapM (showP 0) (init elems)
368 last0 <- showP 0 (last elems)
369 let last = case length elems of
371 _ | isConsLast -> text " | " <> last0
373 return$ brackets (cat (punctuate comma init ++ [last]))
375 where Just a /= Just b = not (a `coreEqType` b)
377 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
378 getListTerms t@Term{subTerms=[]} = []
379 getListTerms t@Suspension{} = [t]
380 getListTerms t = pprPanic "getListTerms" (ppr t)
382 isFullyEvaluatedTerm :: Term -> Bool
383 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
384 isFullyEvaluatedTerm Suspension {} = False
385 isFullyEvaluatedTerm Prim {} = True
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 congruenceNewtypes :: TcType -> TcType -> TcM TcType
413 congruenceNewtypes lhs rhs
414 -- | pprTrace "Congruence" (ppr lhs $$ ppr rhs) False = undefined
415 -- We have a tctyvar at the other side
416 | Just tv <- getTyVar_maybe rhs
417 -- , trace "congruence, entering tyvar" True
418 = recoverM (return rhs) $ do
419 Indirect ty_v <- readMetaTyVar tv
420 newtyped_tytv <- congruenceNewtypes lhs ty_v
421 writeMutVar (metaTvRef tv) (Indirect newtyped_tytv)
423 -- We have a function type: go on inductively
424 | Just (r1,r2) <- splitFunTy_maybe rhs
425 , Just (l1,l2) <- splitFunTy_maybe lhs
426 = liftM2 mkFunTy ( congruenceNewtypes l1 r1)
427 (congruenceNewtypes l2 r2)
428 -- There is a newtype at the top level tycon and we can manage it
429 | Just (tycon, args) <- splitNewTyConApp_maybe lhs
431 , (tvs, realtipe) <- newTyConRep tycon
432 = case tcUnifyTys (const BindMe) [realtipe] [rhs] of
434 let tvs' = substTys subst (map mkTyVarTy tvs) in
435 liftM (mkTyConApp tycon) (zipWithM congruenceNewtypes args tvs')
436 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
438 -- We have a TyconApp: go on inductively
439 | Just (tycon, args) <- splitNewTyConApp_maybe lhs
440 , Just (tycon_v, args_v) <- splitNewTyConApp_maybe rhs
441 = liftM (mkTyConApp tycon_v) (zipWithM congruenceNewtypes args args_v)
443 | otherwise = return rhs
446 newVar :: Kind -> TR TcTyVar
447 newVar = liftTcM . newFlexiTyVar
451 instScheme :: Type -> TR TcType
452 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
453 where fst3 (x,y,z) = x
456 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
457 cvObtainTerm hsc_env force mb_ty a =
458 -- Obtain the term and tidy the type before returning it
459 cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
461 tidyTypes = foldTerm idTermFold {
462 fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
463 fSuspension = \ct mb_ty hval n ->
464 Suspension ct (fmap tidy mb_ty) hval n
466 tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
468 mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
469 | (tv,v) <- zip alphaTyVars vars]
470 where vars = varSetElems$ tyVarsOfType ty
472 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
473 cvObtainTerm1 hsc_env force mb_ty hval
474 | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval
475 | Just ty <- mb_ty = runTR hsc_env $ do
476 term <- go argTypeKind hval
478 addConstraint ty' (fromMaybe (error "by definition")
483 ctype <- trIO$ getClosureType a
485 -- Thunks we may want to force
486 Thunk _ | force -> seq a $ go k a
487 -- We always follow indirections
488 _ | isIndirection ctype
490 clos <- trIO$ getClosureData a
491 -- dflags <- getSessionDynFlags session
492 -- debugTraceMsg dflags 2 (text "Following an indirection")
493 go k $! (ptrs clos ! 0)
494 -- The interesting case
496 m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
498 Nothing -> panic "Can't find the DataCon for a term"
500 clos <- trIO$ getClosureData a
501 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
502 subTtypes = drop extra_args (dataConRepArgTys dc)
503 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
505 subTermsP <- mapM (\i->extractSubterm i (ptrs clos)
506 (subTtypesP!!(i-extra_args)))
507 [extra_args..extra_args + length subTtypesP - 1]
508 let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
509 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
510 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
511 resType <- liftM mkTyVarTy (newVar k)
512 baseType <- instScheme (dataConRepType dc)
513 let myType = mkFunTys (map (fromMaybe undefined . termType)
516 addConstraint baseType myType
517 return (Term resType dc a subTerms)
518 -- The otherwise case: can be a Thunk,AP,PAP,etc.
520 x <- liftM mkTyVarTy (newVar k)
521 return (Suspension ctype (Just x) a Nothing)
523 -- Access the array of pointers and recurse down. Needs to be done with
524 -- care of no introducing a thunk! or go will fail to do its job
525 extractSubterm (I# i#) ptrs ty = case ptrs of
526 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
527 (# e #) -> go (typeKind ty) e
529 -- This is used to put together pointed and nonpointed subterms in the
531 reOrderTerms _ _ [] = []
532 reOrderTerms pointed unpointed (ty:tys)
533 | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
534 | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
536 zonkTerm :: Term -> TcM Term
537 zonkTerm = foldTerm idTermFoldM {
538 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
539 zonkTcType ty >>= \ty' ->
540 return (Term ty' dc v tt)
541 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
542 return (Suspension ct ty v b)}
545 Example of Type Reconstruction
546 --------------------------------
547 Suppose we have an existential type such as
549 data Opaque = forall a. Opaque a
551 And we have a term built as:
553 t = Opaque (map Just [[1,1],[2,2]])
555 The type of t as far as the typechecker goes is t :: Opaque
556 If we seq the head of t, we obtain:
562 t - O ( (_3::b) : (_4::[b]) )
566 t - O ( (Just (_5::c)) : (_4::[b]) )
568 At this point, we know that b = (Maybe c)
572 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
574 At this point, we know that c = [d]
578 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
580 At this point, we know that d = Integer
582 The fully reconstructed expressions, with propagation, would be:
584 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
585 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
586 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
589 For reference, the type of the thing inside the opaque is
590 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
592 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
595 --------------------------------------------------------------------
596 -- The DataConEnv is used to store the addresses of datacons loaded
597 -- via the dynamic linker
598 --------------------------------------------------------------------
600 type DataConEnv = AddressEnv StgInfoTable
602 -- Note that this AddressEnv and DataConEnv I wrote trying to follow
603 -- conventions in ghc, but probably they make not much sense.
605 newtype AddressEnv a = AE {aenv:: FiniteMap (Ptr a) Name}
606 deriving (Outputable)
608 emptyAddressEnv = AE emptyFM
610 extendAddressEnvList :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a
611 elemAddressEnv :: Ptr a -> AddressEnv a -> Bool
612 delFromAddressEnv :: AddressEnv a -> Ptr a -> AddressEnv a
613 nullAddressEnv :: AddressEnv a -> Bool
614 lookupAddressEnv :: AddressEnv a -> Ptr a -> Maybe Name
616 extendAddressEnvList (AE env) = AE . addListToFM env
617 elemAddressEnv ptr (AE env) = ptr `elemFM` env
618 delFromAddressEnv (AE env) = AE . delFromFM env
619 nullAddressEnv = isEmptyFM . aenv
620 lookupAddressEnv (AE env) = lookupFM env
623 instance Outputable (Ptr a) where