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
16 extendAddressEnvList',
\r
24 Closure ( tipe, infoTable, ptrs, nonPtrs ),
\r
33 customPrintTermBase,
\r
41 isFullyEvaluatedTerm,
\r
45 #include "HsVersions.h"
\r
47 import ByteCodeItbls ( StgInfoTable )
\r
48 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
\r
49 import ByteCodeLink ( HValue )
\r
50 import HscTypes ( HscEnv )
\r
65 import Var ( setVarUnique, mkTyVar, tyVarKind, setTyVarKind )
\r
66 import VarEnv ( mkVarEnv )
\r
67 import OccName ( emptyTidyOccEnv )
\r
68 import VarSet ( VarSet, mkVarSet, varSetElems, unionVarSets )
\r
69 import Unique ( getUnique, incrUnique )
\r
70 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
\r
76 import Constants ( wORD_SIZE )
\r
77 import FastString ( mkFastString )
\r
81 import GHC.Arr ( Array(..) )
\r
82 import GHC.Ptr ( Ptr(..), castPtr )
\r
84 import GHC.Int ( Int32(..), Int64(..) )
\r
85 import GHC.Word ( Word32(..), Word64(..) )
\r
87 import Control.Monad ( liftM, liftM2, msum )
\r
90 import Data.Traversable ( mapM )
\r
91 import Data.Array.Base
\r
92 import Foreign.Storable
\r
93 import Foreign ( unsafePerformIO )
\r
95 import Prelude hiding ( mapM )
\r
97 ---------------------------------------------
\r
98 -- * A representation of semi evaluated Terms
\r
99 ---------------------------------------------
\r
101 A few examples in this representation:
\r
103 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
\r
105 > (('a',_,_),_,('b',_,_)) =
\r
106 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
\r
107 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]
\r
109 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]
\r
112 data Term = Term { ty :: Type
\r
115 , subTerms :: [Term] }
\r
117 | Prim { ty :: Type
\r
118 , value :: String }
\r
120 | Suspension { ctype :: ClosureType
\r
121 , mb_ty :: Maybe Type
\r
123 , bound_to :: Maybe Name -- Useful for printing
\r
126 isTerm Term{} = True
\r
128 isSuspension Suspension{} = True
\r
129 isSuspension _ = False
\r
130 isPrim Prim{} = True
\r
133 termType t@(Suspension {}) = mb_ty t
\r
134 termType t = Just$ ty t
\r
136 instance Outputable (Term) where
\r
137 ppr = head . customPrintTerm customPrintTermBase
\r
139 -------------------------------------------------------------------------
\r
140 -- Runtime Closure Datatype and functions for retrieving closure related stuff
\r
141 -------------------------------------------------------------------------
\r
142 data ClosureType = Constr
\r
151 deriving (Show, Eq)
\r
153 data Closure = Closure { tipe :: ClosureType
\r
154 , infoTable :: StgInfoTable
\r
155 , ptrs :: Array Int HValue
\r
156 -- What would be the type here? HValue is ok? Should I build a Ptr?
\r
157 , nonPtrs :: ByteArray#
\r
160 instance Outputable ClosureType where
\r
163 getInfoTablePtr :: a -> Ptr StgInfoTable
\r
164 getInfoTablePtr x =
\r
166 itbl_ptr -> castPtr ( Ptr itbl_ptr )
\r
168 getClosureType :: a -> IO ClosureType
\r
169 getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
\r
171 #include "../includes/ClosureTypes.h"
\r
178 getClosureData :: a -> IO Closure
\r
179 getClosureData a = do
\r
180 itbl <- peek (getInfoTablePtr a)
\r
181 let tipe = readCType (BCI.tipe itbl)
\r
182 case closurePayload# a of
\r
183 (# ptrs, nptrs #) ->
\r
184 let elems = BCI.ptrs itbl
\r
185 ptrsList = Array 0 (fromIntegral$ elems) ptrs
\r
186 in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
\r
188 readCType :: Integral a => a -> ClosureType
\r
190 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
\r
191 | i >= FUN && i <= FUN_STATIC = Fun
\r
192 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
\r
193 | i == THUNK_SELECTOR = ThunkSelector
\r
194 | i == BLACKHOLE = Blackhole
\r
195 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
\r
196 | fromIntegral i == aP_CODE = AP
\r
197 | fromIntegral i == pAP_CODE = PAP
\r
198 | otherwise = Other (fromIntegral i)
\r
200 isConstr, isIndirection :: ClosureType -> Bool
\r
201 isConstr Constr = True
\r
204 isIndirection (Indirection _) = True
\r
205 --isIndirection ThunkSelector = True
\r
206 isIndirection _ = False
\r
208 isFullyEvaluated :: a -> IO Bool
\r
209 isFullyEvaluated a = do
\r
210 closure <- getClosureData a
\r
211 case tipe closure of
\r
212 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
\r
213 return$ and are_subs_evaluated
\r
214 otherwise -> return False
\r
215 where amapM f = sequence . amap' f
\r
217 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
\r
221 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
\r
223 unsafeDeepSeq :: a -> b -> b
\r
224 unsafeDeepSeq = unsafeDeepSeq1 2
\r
225 where unsafeDeepSeq1 0 a b = seq a $! b
\r
226 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
\r
227 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
\r
228 -- | unsafePerformIO (isFullyEvaluated a) = b
\r
229 | otherwise = case unsafePerformIO (getClosureData a) of
\r
230 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
\r
231 where tipe = unsafePerformIO (getClosureType a)
\r
233 isPointed :: Type -> Bool
\r
234 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
\r
237 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
\r
239 extractUnboxed :: [Type] -> ByteArray# -> [String]
\r
240 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
\r
241 where helper :: [Type] -> Addr# -> [String]
\r
242 helper (t:tt) addr
\r
243 | Just ( tycon,_) <- splitTyConApp_maybe t
\r
244 = let (offset, txt) = decode tycon addr
\r
245 (I# word_offset) = offset*wORD_SIZE
\r
246 in txt : helper tt (plusAddr# addr word_offset)
\r
248 = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
\r
249 panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
\r
250 helper [] addr = []
\r
251 decode :: TyCon -> Addr# -> (Int, String)
\r
253 | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)
\r
254 | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)
\r
255 | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)
\r
256 | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)
\r
257 | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
\r
258 | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)
\r
259 | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
\r
260 | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)
\r
261 | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
\r
262 | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses
\r
263 | t == stablePtrPrimTyCon = (1, "<stablePtr>")
\r
264 | t == stableNamePrimTyCon = (1, "<stableName>")
\r
265 | t == statePrimTyCon = (1, "<statethread>")
\r
266 | t == realWorldTyCon = (1, "<realworld>")
\r
267 | t == threadIdPrimTyCon = (1, "<ThreadId>")
\r
268 | t == weakPrimTyCon = (1, "<Weak>")
\r
269 | t == arrayPrimTyCon = (1,"<array>")
\r
270 | t == byteArrayPrimTyCon = (1,"<bytearray>")
\r
271 | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
\r
272 | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
\r
273 | t == mutVarPrimTyCon= (1, "<mutVar>")
\r
274 | t == mVarPrimTyCon = (1, "<mVar>")
\r
275 | t == tVarPrimTyCon = (1, "<tVar>")
\r
276 | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
\r
277 -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
\r
278 -- TODO: Improve the offset handling in decode (make it machine dependant)
\r
280 -----------------------------------
\r
281 -- Boilerplate Fold code for Term
\r
282 -----------------------------------
\r
284 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
\r
285 , fPrim :: Type -> String -> a
\r
286 , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
\r
289 foldTerm :: TermFold a -> Term -> a
\r
290 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
\r
291 foldTerm tf (Prim ty v ) = fPrim tf ty v
\r
292 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
\r
294 idTermFold :: TermFold Term
\r
295 idTermFold = TermFold {
\r
298 fSuspension = Suspension
\r
300 idTermFoldM :: Monad m => TermFold (m Term)
\r
301 idTermFoldM = TermFold {
\r
302 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
\r
303 fPrim = (return.). Prim,
\r
304 fSuspension = (((return.).).). Suspension
\r
307 ----------------------------------
\r
308 -- Pretty printing of terms
\r
309 ----------------------------------
\r
311 parensCond True = parens
\r
312 parensCond False = id
\r
316 printTerm :: Term -> SDoc
\r
317 printTerm Prim{value=value} = text value
\r
318 printTerm t@Term{} = printTerm1 0 t
\r
319 printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
\r
320 printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =
\r
321 parens$ ppr n <> text "::" <> ppr ty
\r
323 printTerm1 p Term{dc=dc, subTerms=tt}
\r
324 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
\r
325 = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
\r
326 <+> hsep (map (printTerm1 True) tt)
\r
329 | otherwise = parensCond (p > app_prec)
\r
330 (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
\r
332 where fixity = undefined
\r
334 printTerm1 _ t = printTerm t
\r
336 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
\r
337 customPrintTerm custom = let
\r
338 -- go :: Monad m => Int -> Term -> m SDoc
\r
339 go prec t@Term{subTerms=tt, dc=dc} = do
\r
340 mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
\r
341 case msum mb_customDocs of -- msum is in Maybe monad
\r
342 Just doc -> return$ parensCond (prec>app_prec+1) doc
\r
343 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
\r
344 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
\r
345 return$ parensCond (prec>app_prec+1)
\r
346 (ppr dc <+> sep pprSubterms)
\r
347 go _ t = return$ printTerm t
\r
349 where fixity = undefined
\r
351 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
\r
352 customPrintTermBase showP =
\r
354 test isTupleDC (liftM (parens . cat . punctuate comma) . mapM (showP 0) . subTerms)
\r
355 , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
\r
356 , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
\r
357 , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
\r
358 -- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
\r
359 , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
\r
360 , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
\r
361 , test isIntegerDC (coerceShow$ \(a::Integer)->a)
\r
363 where test pred f t = if pred t then liftM Just (f t) else return Nothing
\r
364 isIntegerDC Term{dc=dc} =
\r
365 dataConName dc `elem` [ smallIntegerDataConName
\r
366 , largeIntegerDataConName]
\r
367 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
\r
368 isDC a_dc Term{dc=dc} = a_dc == dc
\r
369 coerceShow f Term{val=val} = return . text . show . f . unsafeCoerce# $ val
\r
370 --TODO pprinting of list terms is not lazy
\r
372 let elems = h : getListTerms t
\r
373 isConsLast = isSuspension (last elems) &&
\r
374 (mb_ty$ last elems) /= (termType h)
\r
375 init <- mapM (showP 0) (init elems)
\r
376 last0 <- showP 0 (last elems)
\r
377 let last = case length elems of
\r
379 _ | isConsLast -> text " | " <> last0
\r
380 _ -> comma <> last0
\r
381 return$ brackets (cat (punctuate comma init ++ [last]))
\r
383 where Just a /= Just b = not (a `coreEqType` b)
\r
385 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
\r
386 getListTerms t@Term{subTerms=[]} = []
\r
387 getListTerms t@Suspension{} = [t]
\r
388 getListTerms t = pprPanic "getListTerms" (ppr t)
\r
390 isFullyEvaluatedTerm :: Term -> Bool
\r
391 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
\r
392 isFullyEvaluatedTerm Suspension {} = False
\r
393 isFullyEvaluatedTerm Prim {} = True
\r
396 -----------------------------------
\r
397 -- Type Reconstruction
\r
398 -----------------------------------
\r
400 -- The Type Reconstruction monad
\r
403 runTR :: HscEnv -> TR Term -> IO Term
\r
404 runTR hsc_env c = do
\r
405 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
\r
407 Nothing -> panic "Can't unify"
\r
408 Just term -> return term
\r
410 trIO :: IO a -> TR a
\r
411 trIO = liftTcM . ioToTcRn
\r
413 addConstraint :: TcType -> TcType -> TR ()
\r
414 addConstraint t1 t2 = congruenceNewtypes t1 t2 >> unifyType t1 t2
\r
416 -- A parallel fold over a Type value, replacing
\r
417 -- in the right side reptypes for newtypes as found in the lhs
\r
418 -- Sadly it doesn't cover all the possibilities. It does not always manage
\r
419 -- to recover the highest level type. See test print016 for an example
\r
420 congruenceNewtypes :: TcType -> TcType -> TcM TcType
\r
421 congruenceNewtypes lhs rhs
\r
422 -- | pprTrace "Congruence" (ppr lhs $$ ppr rhs) False = undefined
\r
423 -- We have a tctyvar at the other side
\r
424 | Just tv <- getTyVar_maybe rhs
\r
425 -- , trace "congruence, entering tyvar" True
\r
426 = recoverM (return rhs) $ do
\r
427 Indirect ty_v <- readMetaTyVar tv
\r
428 newtyped_tytv <- congruenceNewtypes lhs ty_v
\r
429 writeMutVar (metaTvRef tv) (Indirect newtyped_tytv)
\r
430 return newtyped_tytv
\r
431 -- We have a function type: go on inductively
\r
432 | Just (r1,r2) <- splitFunTy_maybe rhs
\r
433 , Just (l1,l2) <- splitFunTy_maybe lhs
\r
434 = liftM2 mkFunTy ( congruenceNewtypes l1 r1)
\r
435 (congruenceNewtypes l2 r2)
\r
436 -- There is a newtype at the top level tycon and we can manage it
\r
437 | Just (tycon, args) <- splitNewTyConApp_maybe lhs
\r
439 , (tvs, realtipe) <- newTyConRep tycon
\r
440 = case tcUnifyTys (const BindMe) [realtipe] [rhs] of
\r
442 let tvs' = substTys subst (map mkTyVarTy tvs) in
\r
443 liftM (mkTyConApp tycon) (zipWithM congruenceNewtypes args tvs')
\r
444 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
\r
446 -- We have a TyconApp: go on inductively
\r
447 | Just (tycon, args) <- splitNewTyConApp_maybe lhs
\r
448 , Just (tycon_v, args_v) <- splitNewTyConApp_maybe rhs
\r
449 = liftM (mkTyConApp tycon_v) (zipWithM congruenceNewtypes args args_v)
\r
451 | otherwise = return rhs
\r
454 newVar :: Kind -> TR TcTyVar
\r
455 newVar = liftTcM . newFlexiTyVar
\r
459 instScheme :: Type -> TR TcType
\r
460 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
\r
461 where fst3 (x,y,z) = x
\r
464 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
\r
465 cvObtainTerm hsc_env force mb_ty a =
\r
466 -- Obtain the term and tidy the type before returning it
\r
467 cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
\r
469 tidyTypes = foldTerm idTermFold {
\r
470 fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
\r
471 fSuspension = \ct mb_ty hval n ->
\r
472 Suspension ct (fmap tidy mb_ty) hval n
\r
474 tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
\r
476 mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
\r
477 | (tv,v) <- zip alphaTyVars vars]
\r
478 where vars = varSetElems$ tyVarsOfType ty
\r
480 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
\r
481 cvObtainTerm1 hsc_env force mb_ty hval
\r
482 | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval
\r
483 | Just ty <- mb_ty = runTR hsc_env $ do
\r
484 term <- go argTypeKind hval
\r
485 ty' <- instScheme ty
\r
486 addConstraint ty' (fromMaybe (error "by definition")
\r
491 ctype <- trIO$ getClosureType a
\r
493 -- Thunks we may want to force
\r
494 Thunk _ | force -> seq a $ go k a
\r
495 -- We always follow indirections
\r
496 _ | isIndirection ctype
\r
498 clos <- trIO$ getClosureData a
\r
499 -- dflags <- getSessionDynFlags session
\r
500 -- debugTraceMsg dflags 2 (text "Following an indirection")
\r
501 go k $! (ptrs clos ! 0)
\r
502 -- The interesting case
\r
504 m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
\r
506 Nothing -> panic "Can't find the DataCon for a term"
\r
508 clos <- trIO$ getClosureData a
\r
509 let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
\r
510 subTtypes = drop extra_args (dataConRepArgTys dc)
\r
511 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
\r
513 subTermsP <- mapM (\i->extractSubterm i (ptrs clos)
\r
514 (subTtypesP!!(i-extra_args)))
\r
515 [extra_args..extra_args + length subTtypesP - 1]
\r
516 let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
\r
517 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
\r
518 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
\r
519 resType <- liftM mkTyVarTy (newVar k)
\r
520 baseType <- instScheme (dataConRepType dc)
\r
521 let myType = mkFunTys (map (fromMaybe undefined . termType)
\r
524 addConstraint baseType myType
\r
525 return (Term resType dc a subTerms)
\r
526 -- The otherwise case: can be a Thunk,AP,PAP,etc.
\r
528 x <- liftM mkTyVarTy (newVar k)
\r
529 return (Suspension ctype (Just x) a Nothing)
\r
531 -- Access the array of pointers and recurse down. Needs to be done with
\r
532 -- care of no introducing a thunk! or go will fail to do its job
\r
533 extractSubterm (I# i#) ptrs ty = case ptrs of
\r
534 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
\r
535 (# e #) -> go (typeKind ty) e
\r
537 -- This is used to put together pointed and nonpointed subterms in the
\r
539 reOrderTerms _ _ [] = []
\r
540 reOrderTerms pointed unpointed (ty:tys)
\r
541 | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
\r
542 | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys
\r
544 zonkTerm :: Term -> TcM Term
\r
545 zonkTerm = foldTerm idTermFoldM {
\r
546 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
\r
547 zonkTcType ty >>= \ty' ->
\r
548 return (Term ty' dc v tt)
\r
549 ,fSuspension = \ct ty v b -> mapM zonkTcType ty >>= \ty ->
\r
550 return (Suspension ct ty v b)}
\r
553 Example of Type Reconstruction
\r
554 --------------------------------
\r
555 Suppose we have an existential type such as
\r
557 data Opaque = forall a. Opaque a
\r
559 And we have a term built as:
\r
561 t = Opaque (map Just [[1,1],[2,2]])
\r
563 The type of t as far as the typechecker goes is t :: Opaque
\r
564 If we seq the head of t, we obtain:
\r
570 t - O ( (_3::b) : (_4::[b]) )
\r
574 t - O ( (Just (_5::c)) : (_4::[b]) )
\r
576 At this point, we know that b = (Maybe c)
\r
580 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
\r
582 At this point, we know that c = [d]
\r
586 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
\r
588 At this point, we know that d = Integer
\r
590 The fully reconstructed expressions, with propagation, would be:
\r
592 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
\r
593 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
\r
594 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
\r
597 For reference, the type of the thing inside the opaque is
\r
598 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
\r
600 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
\r
603 --------------------------------------------------------------------
\r
604 -- The DataConEnv is used to store the addresses of datacons loaded
\r
605 -- via the dynamic linker
\r
606 --------------------------------------------------------------------
\r
608 type DataConEnv = AddressEnv StgInfoTable
\r
610 -- Note that this AddressEnv and DataConEnv I wrote trying to follow
\r
611 -- conventions in ghc, but probably they make no sense. Should
\r
612 -- probably be replaced by a plain Data.Map
\r
614 newtype AddressEnv a = AE {outAE::[(Ptr a, Name)]}
\r
616 emptyAddressEnv = AE []
\r
618 extendAddressEnvList :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a
\r
619 extendAddressEnvList' :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a
\r
620 elemAddressEnv :: Ptr a -> AddressEnv a -> Bool
\r
621 delFromAddressEnv :: AddressEnv a -> Ptr a -> AddressEnv a
\r
622 nullAddressEnv :: AddressEnv a -> Bool
\r
623 lookupAddressEnv :: AddressEnv a -> Ptr a -> Maybe Name
\r
625 extendAddressEnvList (AE env) = AE . nub . (++ env)
\r
626 extendAddressEnvList' (AE env) = AE . (++ env)
\r
627 elemAddressEnv ptr (AE env) = ptr `elem` fst (unzip env)
\r
628 delFromAddressEnv (AE env) ptr = AE [(ptr', n) | (ptr', n) <- env, ptr' /= ptr]
\r
629 nullAddressEnv = null . outAE
\r
630 lookupAddressEnv (AE env) = flip lookup env
\r
632 instance Outputable (AddressEnv a) where
\r
633 ppr (AE ae) = vcat [text (show ptr) <> comma <> ppr a | (ptr,a) <- ae]
\r