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