--- /dev/null
+-----------------------------------------------------------------------------\r
+--\r
+-- GHC Interactive support for inspecting arbitrary closures at runtime\r
+--\r
+-- Pepe Iborra (supported by Google SoC) 2006\r
+--\r
+-----------------------------------------------------------------------------\r
+\r
+module RtClosureInspect(\r
+ \r
+ cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term\r
+\r
+ AddressEnv(..), \r
+ DataConEnv,\r
+ extendAddressEnvList, \r
+ extendAddressEnvList', \r
+ elemAddressEnv, \r
+ delFromAddressEnv, \r
+ emptyAddressEnv, \r
+ lookupAddressEnv, \r
+\r
+ ClosureType(..), \r
+ getClosureData, \r
+ Closure ( tipe, infoTable, ptrs, nonPtrs ), \r
+ getClosureType, \r
+ isConstr, \r
+ isIndirection,\r
+ getInfoTablePtr, \r
+\r
+ Term(..), \r
+ printTerm, \r
+ customPrintTerm, \r
+ customPrintTermBase,\r
+ termType,\r
+ foldTerm, \r
+ TermFold(..), \r
+ idTermFold, \r
+ idTermFoldM,\r
+ isFullyEvaluated, \r
+ isPointed,\r
+ isFullyEvaluatedTerm,\r
+-- unsafeDeepSeq, \r
+ ) where \r
+\r
+#include "HsVersions.h"\r
+\r
+import ByteCodeItbls ( StgInfoTable )\r
+import qualified ByteCodeItbls as BCI( StgInfoTable(..) )\r
+import ByteCodeLink ( HValue )\r
+import HscTypes ( HscEnv )\r
+\r
+import DataCon \r
+import Type \r
+import TcRnMonad\r
+import TcType\r
+import TcMType\r
+import TcUnify\r
+import TcGadt\r
+import DriverPhases\r
+import TyCon \r
+import Var\r
+import Name \r
+import Unique\r
+import UniqSupply\r
+import Var ( setVarUnique, mkTyVar, tyVarKind, setTyVarKind )\r
+import VarEnv ( mkVarEnv )\r
+import OccName ( emptyTidyOccEnv )\r
+import VarSet ( VarSet, mkVarSet, varSetElems, unionVarSets )\r
+import Unique ( getUnique, incrUnique )\r
+import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )\r
+\r
+import TysPrim \r
+import PrelNames\r
+import TysWiredIn\r
+\r
+import Constants ( wORD_SIZE )\r
+import FastString ( mkFastString )\r
+import Outputable\r
+import Panic\r
+\r
+import GHC.Arr ( Array(..) )\r
+import GHC.Ptr ( Ptr(..), castPtr )\r
+import GHC.Exts \r
+import GHC.Int ( Int32(..), Int64(..) )\r
+import GHC.Word ( Word32(..), Word64(..) )\r
+\r
+import Control.Monad ( liftM, liftM2, msum )\r
+import Data.Maybe\r
+import Data.List\r
+import Data.Traversable ( mapM )\r
+import Data.Array.Base\r
+import Foreign.Storable\r
+import Foreign ( unsafePerformIO )\r
+\r
+import Prelude hiding ( mapM )\r
+\r
+---------------------------------------------\r
+-- * A representation of semi evaluated Terms\r
+---------------------------------------------\r
+{-\r
+ A few examples in this representation:\r
+\r
+ > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]\r
+\r
+ > (('a',_,_),_,('b',_,_)) = \r
+ Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))\r
+ [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]\r
+ , Thunk\r
+ , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]\r
+-}\r
+\r
+data Term = Term { ty :: Type \r
+ , dc :: DataCon \r
+ , val :: HValue \r
+ , subTerms :: [Term] }\r
+\r
+ | Prim { ty :: Type\r
+ , value :: String }\r
+\r
+ | Suspension { ctype :: ClosureType\r
+ , mb_ty :: Maybe Type\r
+ , val :: HValue\r
+ , bound_to :: Maybe Name -- Useful for printing\r
+ }\r
+\r
+isTerm Term{} = True\r
+isTerm _ = False\r
+isSuspension Suspension{} = True\r
+isSuspension _ = False\r
+isPrim Prim{} = True\r
+isPrim _ = False\r
+\r
+termType t@(Suspension {}) = mb_ty t\r
+termType t = Just$ ty t\r
+\r
+instance Outputable (Term) where\r
+ ppr = head . customPrintTerm customPrintTermBase\r
+\r
+-------------------------------------------------------------------------\r
+-- Runtime Closure Datatype and functions for retrieving closure related stuff\r
+-------------------------------------------------------------------------\r
+data ClosureType = Constr \r
+ | Fun \r
+ | Thunk Int \r
+ | ThunkSelector\r
+ | Blackhole \r
+ | AP \r
+ | PAP \r
+ | Indirection Int \r
+ | Other Int\r
+ deriving (Show, Eq)\r
+\r
+data Closure = Closure { tipe :: ClosureType \r
+ , infoTable :: StgInfoTable\r
+ , ptrs :: Array Int HValue\r
+ -- What would be the type here? HValue is ok? Should I build a Ptr?\r
+ , nonPtrs :: ByteArray# \r
+ }\r
+\r
+instance Outputable ClosureType where\r
+ ppr = text . show \r
+\r
+getInfoTablePtr :: a -> Ptr StgInfoTable\r
+getInfoTablePtr x = \r
+ case infoPtr# x of\r
+ itbl_ptr -> castPtr ( Ptr itbl_ptr )\r
+\r
+getClosureType :: a -> IO ClosureType\r
+getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr\r
+\r
+#include "../includes/ClosureTypes.h"\r
+\r
+aP_CODE = AP\r
+pAP_CODE = PAP\r
+#undef AP\r
+#undef PAP\r
+\r
+getClosureData :: a -> IO Closure\r
+getClosureData a = do\r
+ itbl <- peek (getInfoTablePtr a)\r
+ let tipe = readCType (BCI.tipe itbl)\r
+ case closurePayload# a of \r
+ (# ptrs, nptrs #) -> \r
+ let elems = BCI.ptrs itbl \r
+ ptrsList = Array 0 (fromIntegral$ elems) ptrs\r
+ in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)\r
+\r
+readCType :: Integral a => a -> ClosureType\r
+readCType i\r
+ | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr\r
+ | i >= FUN && i <= FUN_STATIC = Fun\r
+ | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)\r
+ | i == THUNK_SELECTOR = ThunkSelector\r
+ | i == BLACKHOLE = Blackhole\r
+ | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)\r
+ | fromIntegral i == aP_CODE = AP\r
+ | fromIntegral i == pAP_CODE = PAP\r
+ | otherwise = Other (fromIntegral i)\r
+\r
+isConstr, isIndirection :: ClosureType -> Bool\r
+isConstr Constr = True\r
+isConstr _ = False\r
+\r
+isIndirection (Indirection _) = True\r
+--isIndirection ThunkSelector = True\r
+isIndirection _ = False\r
+\r
+isFullyEvaluated :: a -> IO Bool\r
+isFullyEvaluated a = do \r
+ closure <- getClosureData a \r
+ case tipe closure of\r
+ Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)\r
+ return$ and are_subs_evaluated\r
+ otherwise -> return False\r
+ where amapM f = sequence . amap' f\r
+\r
+amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of\r
+ (# e #) -> f e)\r
+ [0 .. i - i0]\r
+\r
+-- TODO: Fix it. Probably the otherwise case is failing, trace/debug it\r
+{-\r
+unsafeDeepSeq :: a -> b -> b\r
+unsafeDeepSeq = unsafeDeepSeq1 2\r
+ where unsafeDeepSeq1 0 a b = seq a $! b\r
+ unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks\r
+ | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b \r
+ -- | unsafePerformIO (isFullyEvaluated a) = b\r
+ | otherwise = case unsafePerformIO (getClosureData a) of\r
+ closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)\r
+ where tipe = unsafePerformIO (getClosureType a)\r
+-}\r
+isPointed :: Type -> Bool\r
+isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)\r
+isPointed _ = True\r
+\r
+#define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))\r
+\r
+extractUnboxed :: [Type] -> ByteArray# -> [String]\r
+extractUnboxed tt ba = helper tt (byteArrayContents# ba)\r
+ where helper :: [Type] -> Addr# -> [String]\r
+ helper (t:tt) addr \r
+ | Just ( tycon,_) <- splitTyConApp_maybe t \r
+ = let (offset, txt) = decode tycon addr\r
+ (I# word_offset) = offset*wORD_SIZE\r
+ in txt : helper tt (plusAddr# addr word_offset)\r
+ | otherwise \r
+ = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]\r
+ panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)\r
+ helper [] addr = []\r
+ decode :: TyCon -> Addr# -> (Int, String)\r
+ decode t addr \r
+ | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)\r
+ | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)\r
+ | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)\r
+ | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)\r
+ | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)\r
+ | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)\r
+ | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)\r
+ | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)\r
+ | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)\r
+ | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses\r
+ | t == stablePtrPrimTyCon = (1, "<stablePtr>")\r
+ | t == stableNamePrimTyCon = (1, "<stableName>")\r
+ | t == statePrimTyCon = (1, "<statethread>")\r
+ | t == realWorldTyCon = (1, "<realworld>")\r
+ | t == threadIdPrimTyCon = (1, "<ThreadId>")\r
+ | t == weakPrimTyCon = (1, "<Weak>")\r
+ | t == arrayPrimTyCon = (1,"<array>")\r
+ | t == byteArrayPrimTyCon = (1,"<bytearray>")\r
+ | t == mutableArrayPrimTyCon = (1, "<mutableArray>")\r
+ | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")\r
+ | t == mutVarPrimTyCon= (1, "<mutVar>")\r
+ | t == mVarPrimTyCon = (1, "<mVar>")\r
+ | t == tVarPrimTyCon = (1, "<tVar>")\r
+ | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>')) \r
+ -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!\r
+ -- TODO: Improve the offset handling in decode (make it machine dependant)\r
+\r
+-----------------------------------\r
+-- Boilerplate Fold code for Term\r
+-----------------------------------\r
+\r
+data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a\r
+ , fPrim :: Type -> String -> a\r
+ , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a\r
+ }\r
+\r
+foldTerm :: TermFold a -> Term -> a\r
+foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)\r
+foldTerm tf (Prim ty v ) = fPrim tf ty v\r
+foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b\r
+\r
+idTermFold :: TermFold Term\r
+idTermFold = TermFold {\r
+ fTerm = Term,\r
+ fPrim = Prim,\r
+ fSuspension = Suspension\r
+ }\r
+idTermFoldM :: Monad m => TermFold (m Term)\r
+idTermFoldM = TermFold {\r
+ fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,\r
+ fPrim = (return.). Prim,\r
+ fSuspension = (((return.).).). Suspension\r
+ }\r
+\r
+----------------------------------\r
+-- Pretty printing of terms\r
+----------------------------------\r
+\r
+parensCond True = parens\r
+parensCond False = id\r
+app_prec::Int\r
+app_prec = 10\r
+\r
+printTerm :: Term -> SDoc\r
+printTerm Prim{value=value} = text value \r
+printTerm t@Term{} = printTerm1 0 t \r
+printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'\r
+printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =\r
+ parens$ ppr n <> text "::" <> ppr ty \r
+\r
+printTerm1 p Term{dc=dc, subTerms=tt} \r
+{- | dataConIsInfix dc, (t1:t2:tt') <- tt \r
+ = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2) \r
+ <+> hsep (map (printTerm1 True) tt) \r
+-}\r
+ | null tt = ppr dc\r
+ | otherwise = parensCond (p > app_prec) \r
+ (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))\r
+\r
+ where fixity = undefined \r
+\r
+printTerm1 _ t = printTerm t\r
+\r
+customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc\r
+customPrintTerm custom = let \r
+-- go :: Monad m => Int -> Term -> m SDoc\r
+ go prec t@Term{subTerms=tt, dc=dc} = do\r
+ mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad\r
+ case msum mb_customDocs of -- msum is in Maybe monad\r
+ Just doc -> return$ parensCond (prec>app_prec+1) doc\r
+-- | dataConIsInfix dc, (t1:t2:tt') <- tt =\r
+ Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt\r
+ return$ parensCond (prec>app_prec+1) \r
+ (ppr dc <+> sep pprSubterms)\r
+ go _ t = return$ printTerm t\r
+ in go 0 \r
+ where fixity = undefined \r
+\r
+customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]\r
+customPrintTermBase showP =\r
+ [ \r
+ test isTupleDC (liftM (parens . cat . punctuate comma) . mapM (showP 0) . subTerms)\r
+ , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)\r
+ , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)\r
+ , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)\r
+-- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)\r
+ , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)\r
+ , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)\r
+ , test isIntegerDC (coerceShow$ \(a::Integer)->a)\r
+ ] \r
+ where test pred f t = if pred t then liftM Just (f t) else return Nothing\r
+ isIntegerDC Term{dc=dc} = \r
+ dataConName dc `elem` [ smallIntegerDataConName\r
+ , largeIntegerDataConName] \r
+ isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))\r
+ isDC a_dc Term{dc=dc} = a_dc == dc\r
+ coerceShow f Term{val=val} = return . text . show . f . unsafeCoerce# $ val\r
+ --TODO pprinting of list terms is not lazy\r
+ doList h t = do\r
+ let elems = h : getListTerms t\r
+ isConsLast = isSuspension (last elems) && \r
+ (mb_ty$ last elems) /= (termType h)\r
+ init <- mapM (showP 0) (init elems) \r
+ last0 <- showP 0 (last elems)\r
+ let last = case length elems of \r
+ 1 -> last0 \r
+ _ | isConsLast -> text " | " <> last0\r
+ _ -> comma <> last0\r
+ return$ brackets (cat (punctuate comma init ++ [last]))\r
+\r
+ where Just a /= Just b = not (a `coreEqType` b)\r
+ _ /= _ = True\r
+ getListTerms Term{subTerms=[h,t]} = h : getListTerms t\r
+ getListTerms t@Term{subTerms=[]} = []\r
+ getListTerms t@Suspension{} = [t]\r
+ getListTerms t = pprPanic "getListTerms" (ppr t)\r
+\r
+isFullyEvaluatedTerm :: Term -> Bool\r
+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt\r
+isFullyEvaluatedTerm Suspension {} = False\r
+isFullyEvaluatedTerm Prim {} = True\r
+\r
+\r
+-----------------------------------\r
+-- Type Reconstruction\r
+-----------------------------------\r
+\r
+-- The Type Reconstruction monad\r
+type TR a = TcM a\r
+\r
+runTR :: HscEnv -> TR Term -> IO Term\r
+runTR hsc_env c = do \r
+ mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)\r
+ case mb_term of \r
+ Nothing -> panic "Can't unify"\r
+ Just term -> return term\r
+\r
+trIO :: IO a -> TR a \r
+trIO = liftTcM . ioToTcRn\r
+\r
+addConstraint :: TcType -> TcType -> TR ()\r
+addConstraint t1 t2 = congruenceNewtypes t1 t2 >> unifyType t1 t2\r
+\r
+-- A parallel fold over a Type value, replacing\r
+-- in the right side reptypes for newtypes as found in the lhs\r
+-- Sadly it doesn't cover all the possibilities. It does not always manage\r
+-- to recover the highest level type. See test print016 for an example\r
+congruenceNewtypes :: TcType -> TcType -> TcM TcType\r
+congruenceNewtypes lhs rhs\r
+-- | pprTrace "Congruence" (ppr lhs $$ ppr rhs) False = undefined\r
+ -- We have a tctyvar at the other side\r
+ | Just tv <- getTyVar_maybe rhs \r
+-- , trace "congruence, entering tyvar" True\r
+ = recoverM (return rhs) $ do \r
+ Indirect ty_v <- readMetaTyVar tv\r
+ newtyped_tytv <- congruenceNewtypes lhs ty_v\r
+ writeMutVar (metaTvRef tv) (Indirect newtyped_tytv)\r
+ return newtyped_tytv\r
+-- We have a function type: go on inductively\r
+ | Just (r1,r2) <- splitFunTy_maybe rhs\r
+ , Just (l1,l2) <- splitFunTy_maybe lhs\r
+ = liftM2 mkFunTy ( congruenceNewtypes l1 r1)\r
+ (congruenceNewtypes l2 r2)\r
+-- There is a newtype at the top level tycon and we can manage it\r
+ | Just (tycon, args) <- splitNewTyConApp_maybe lhs\r
+ , isNewTyCon tycon\r
+ , (tvs, realtipe) <- newTyConRep tycon\r
+ = case tcUnifyTys (const BindMe) [realtipe] [rhs] of\r
+ Just subst -> \r
+ let tvs' = substTys subst (map mkTyVarTy tvs) in\r
+ liftM (mkTyConApp tycon) (zipWithM congruenceNewtypes args tvs')\r
+ otherwise -> panic "congruenceNewtypes: Can't unify a newtype"\r
+ \r
+-- We have a TyconApp: go on inductively\r
+ | Just (tycon, args) <- splitNewTyConApp_maybe lhs\r
+ , Just (tycon_v, args_v) <- splitNewTyConApp_maybe rhs\r
+ = liftM (mkTyConApp tycon_v) (zipWithM congruenceNewtypes args args_v)\r
+\r
+ | otherwise = return rhs\r
+\r
+\r
+newVar :: Kind -> TR TcTyVar\r
+newVar = liftTcM . newFlexiTyVar\r
+\r
+liftTcM = id\r
+\r
+instScheme :: Type -> TR TcType\r
+instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)\r
+ where fst3 (x,y,z) = x\r
+ trd (x,y,z) = z\r
+\r
+cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term\r
+cvObtainTerm hsc_env force mb_ty a = \r
+ -- Obtain the term and tidy the type before returning it\r
+ cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes \r
+ where \r
+ tidyTypes = foldTerm idTermFold {\r
+ fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,\r
+ fSuspension = \ct mb_ty hval n -> \r
+ Suspension ct (fmap tidy mb_ty) hval n\r
+ }\r
+ tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty \r
+ tidyVarEnv ty = \r
+ mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))\r
+ | (tv,v) <- zip alphaTyVars vars]\r
+ where vars = varSetElems$ tyVarsOfType ty\r
+\r
+cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term\r
+cvObtainTerm1 hsc_env force mb_ty hval\r
+ | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval\r
+ | Just ty <- mb_ty = runTR hsc_env $ do\r
+ term <- go argTypeKind hval\r
+ ty' <- instScheme ty\r
+ addConstraint ty' (fromMaybe (error "by definition") \r
+ (termType term)) \r
+ return term\r
+ where \r
+ go k a = do \r
+ ctype <- trIO$ getClosureType a\r
+ case ctype of\r
+-- Thunks we may want to force\r
+ Thunk _ | force -> seq a $ go k a\r
+-- We always follow indirections \r
+ _ | isIndirection ctype \r
+ -> do\r
+ clos <- trIO$ getClosureData a\r
+-- dflags <- getSessionDynFlags session\r
+-- debugTraceMsg dflags 2 (text "Following an indirection")\r
+ go k $! (ptrs clos ! 0)\r
+ -- The interesting case\r
+ Constr -> do\r
+ m_dc <- trIO$ tcRnRecoverDataCon hsc_env a\r
+ case m_dc of\r
+ Nothing -> panic "Can't find the DataCon for a term"\r
+ Just dc -> do \r
+ clos <- trIO$ getClosureData a\r
+ let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)\r
+ subTtypes = drop extra_args (dataConRepArgTys dc)\r
+ (subTtypesP, subTtypesNP) = partition isPointed subTtypes\r
+ \r
+ subTermsP <- mapM (\i->extractSubterm i (ptrs clos)\r
+ (subTtypesP!!(i-extra_args)))\r
+ [extra_args..extra_args + length subTtypesP - 1]\r
+ let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)\r
+ subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds) \r
+ subTerms = reOrderTerms subTermsP subTermsNP subTtypes\r
+ resType <- liftM mkTyVarTy (newVar k)\r
+ baseType <- instScheme (dataConRepType dc)\r
+ let myType = mkFunTys (map (fromMaybe undefined . termType) \r
+ subTerms) \r
+ resType\r
+ addConstraint baseType myType\r
+ return (Term resType dc a subTerms)\r
+-- The otherwise case: can be a Thunk,AP,PAP,etc.\r
+ otherwise -> do\r
+ x <- liftM mkTyVarTy (newVar k)\r
+ return (Suspension ctype (Just x) a Nothing)\r
+\r
+-- Access the array of pointers and recurse down. Needs to be done with\r
+-- care of no introducing a thunk! or go will fail to do its job \r
+ extractSubterm (I# i#) ptrs ty = case ptrs of \r
+ (Array _ _ ptrs#) -> case indexArray# ptrs# i# of \r
+ (# e #) -> go (typeKind ty) e\r
+\r
+-- This is used to put together pointed and nonpointed subterms in the \r
+-- correct order.\r
+ reOrderTerms _ _ [] = []\r
+ reOrderTerms pointed unpointed (ty:tys) \r
+ | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys\r
+ | otherwise = head unpointed : reOrderTerms pointed (tail unpointed) tys\r
+\r
+zonkTerm :: Term -> TcM Term\r
+zonkTerm = foldTerm idTermFoldM {\r
+ fTerm = \ty dc v tt -> sequence tt >>= \tt ->\r
+ zonkTcType ty >>= \ty' ->\r
+ return (Term ty' dc v tt)\r
+ ,fSuspension = \ct ty v b -> mapM zonkTcType ty >>= \ty ->\r
+ return (Suspension ct ty v b)} \r
+\r
+{-\r
+Example of Type Reconstruction\r
+--------------------------------\r
+Suppose we have an existential type such as\r
+\r
+data Opaque = forall a. Opaque a\r
+\r
+And we have a term built as:\r
+\r
+t = Opaque (map Just [[1,1],[2,2]])\r
+\r
+The type of t as far as the typechecker goes is t :: Opaque\r
+If we seq the head of t, we obtain:\r
+\r
+t - O (_1::a) \r
+\r
+seq _1 ()\r
+\r
+t - O ( (_3::b) : (_4::[b]) ) \r
+\r
+seq _3 ()\r
+\r
+t - O ( (Just (_5::c)) : (_4::[b]) ) \r
+\r
+At this point, we know that b = (Maybe c)\r
+\r
+seq _5 ()\r
+\r
+t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )\r
+\r
+At this point, we know that c = [d]\r
+\r
+seq _6 ()\r
+\r
+t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )\r
+\r
+At this point, we know that d = Integer\r
+\r
+The fully reconstructed expressions, with propagation, would be:\r
+\r
+t - O ( (Just (_5::c)) : (_4::[Maybe c]) ) \r
+t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )\r
+t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )\r
+\r
+\r
+For reference, the type of the thing inside the opaque is \r
+map Just [[1,1],[2,2]] :: [Maybe [Integer]]\r
+\r
+NOTE: (Num t) contexts have been manually replaced by Integer for clarity\r
+-}\r
+\r
+--------------------------------------------------------------------\r
+-- The DataConEnv is used to store the addresses of datacons loaded\r
+-- via the dynamic linker\r
+--------------------------------------------------------------------\r
+\r
+type DataConEnv = AddressEnv StgInfoTable\r
+\r
+-- Note that this AddressEnv and DataConEnv I wrote trying to follow \r
+-- conventions in ghc, but probably they make no sense. Should \r
+-- probably be replaced by a plain Data.Map\r
+\r
+newtype AddressEnv a = AE {outAE::[(Ptr a, Name)]}\r
+\r
+emptyAddressEnv = AE []\r
+\r
+extendAddressEnvList :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a\r
+extendAddressEnvList' :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a\r
+elemAddressEnv :: Ptr a -> AddressEnv a -> Bool\r
+delFromAddressEnv :: AddressEnv a -> Ptr a -> AddressEnv a\r
+nullAddressEnv :: AddressEnv a -> Bool\r
+lookupAddressEnv :: AddressEnv a -> Ptr a -> Maybe Name\r
+\r
+extendAddressEnvList (AE env) = AE . nub . (++ env) \r
+extendAddressEnvList' (AE env) = AE . (++ env)\r
+elemAddressEnv ptr (AE env) = ptr `elem` fst (unzip env) \r
+delFromAddressEnv (AE env) ptr = AE [(ptr', n) | (ptr', n) <- env, ptr' /= ptr]\r
+nullAddressEnv = null . outAE\r
+lookupAddressEnv (AE env) = flip lookup env\r
+\r
+instance Outputable (AddressEnv a) where\r
+ ppr (AE ae) = vcat [text (show ptr) <> comma <> ppr a | (ptr,a) <- ae] \r
+\r
+\r
projects / ghc-hetmet.git / commitdiff