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