import Linker
import RtClosureInspect
+import GhcMonad
import HscTypes
-import IdInfo
import Id
import Name
import Var hiding ( varName )
import VarSet
-import Name
import UniqSupply
import TcType
import GHC
-import DynFlags
import InteractiveEval
import Outputable
-import SrcLoc
import PprTyThing
import MonadUtils
-import Exception
import Control.Monad
import Data.List
import Data.Maybe
let ids = [id | AnId id <- tythings]
-- Obtain the terms and the recovered type information
- (terms, substs) <- unzip `liftM` mapM go ids
-
+ (subst, terms) <- mapAccumLM go emptyTvSubst ids
+
-- Apply the substitutions obtained after recovering the types
modifySession $ \hsc_env ->
- hsc_env{hsc_IC = foldr (flip substInteractiveContext)
- (hsc_IC hsc_env)
- (map skolemiseSubst substs)}
+ hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
+
-- Finally, print the Terms
unqual <- GHC.getPrintUnqual
docterms <- mapM showTerm terms
ids
docterms)
where
-
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
- go :: GhcMonad m => Id -> m (Term, TvSubst)
- go id = do
- term_ <- GHC.obtainTerm force id
+ go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
+ go subst id = do
+ let id' = id `setIdType` substTy subst (idType id)
+ term_ <- GHC.obtainTermFromId maxBound force id'
term <- tidyTermTyVars term_
- term' <- if bindThings &&
+ term' <- if bindThings &&
False == isUnliftedTypeKind (termType term)
then bindSuspensions term
else return term
-- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let reconstructed_type = termType term
- mb_subst <- withSession $ \hsc_env ->
- liftIO $ improveRTTIType hsc_env (idType id) (reconstructed_type)
- return (term', fromMaybe emptyTvSubst mb_subst)
+ hsc_env <- getSession
+ case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
+ Nothing -> return (subst, term')
+ Just subst' -> do { traceOptIf Opt_D_dump_rtti
+ (fsep $ [text "RTTI Improvement for", ppr id,
+ text "is the substitution:" , ppr subst'])
+ ; return (subst `unionTvSubst` subst', term')}
tidyTermTyVars :: GhcMonad m => Term -> m Term
tidyTermTyVars t =
withSession $ \hsc_env -> do
- let env_tvs = ic_tyvars (hsc_IC hsc_env)
+ let env_tvs = tyVarsOfTypes (map idType (ic_tmp_ids (hsc_IC hsc_env)))
my_tvs = termTyVars t
tvs = env_tvs `minusVarSet` my_tvs
tyvarOccName = nameOccName . tyVarName
availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
- let tys' = map (fst.skolemiseTy) tys
- let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
- | (name,ty) <- zip names tys']
- new_tyvars = tyVarsOfTypes tys'
- new_ic = extendInteractiveContext ictxt ids new_tyvars
+ let ids = [ mkVanillaGlobal name ty
+ | (name,ty) <- zip names tys]
+ new_ic = extendInteractiveContext ictxt ids
liftIO $ extendLinkEnv (zip names hvals)
modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
return t'
-- with the changed error handling and logging?
let noop_log _ _ _ _ = return ()
expr = "show " ++ showSDoc (ppr bname)
- GHC.setSessionDynFlags dflags{log_action=noop_log}
+ _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
txt_ <- withExtendedLinkEnv [(bname, val)]
(GHC.compileExpr expr)
let myprec = 10 -- application precedence. TODO Infix constructors
name <- newGrimName userName
let ictxt = hsc_IC hsc_env
tmp_ids = ic_tmp_ids ictxt
- id = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
+ id = mkVanillaGlobal name ty
new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
return (hsc_env {hsc_IC = new_ic }, name)
if pcontents
then do
let depthBound = 100
- terms <- mapM (GHC.obtainTermB depthBound False) ids
+ terms <- mapM (GHC.obtainTermFromId depthBound False) ids
docs_terms <- mapM showTerm terms
return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
(map (pprTyThing pefas . AnId) ids)
docs_terms
else return $ vcat $ map (pprTyThing pefas . AnId) ids
+
+--------------------------------------------------------------
+-- Utils
+
+traceOptIf :: GhcMonad m => DynFlag -> SDoc -> m ()
+traceOptIf flag doc = do
+ dflags <- GHC.getSessionDynFlags
+ when (dopt flag dflags) $ liftIO $ printForUser stderr alwaysQualify doc