Commit decbb181 authored by pepe's avatar pepe

Fix a couple of issues with :print

      
      - Ticket #1995: Unsoundness with newtypes
      - Ticket #2475: "Can't unify" error when stopped at an exception
      
      In addition this patch adds the following:
      
      - Unfailingness: RTTI cannot panic anymore. 
        In case of failure, it recovers gracefully by returning the "I know nothing" type
      - A -ddump-rtti flag
parent f0338529
......@@ -53,13 +53,15 @@ pprintClosureCommand bindThings force str = do
let ids = [id | AnId id <- tythings]
-- Obtain the terms and the recovered type information
(terms, substs) <- unzip `liftM` mapM go ids
(terms, substs0) <- unzip `liftM` mapM go 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)}
let (substs, skol_vars) = unzip$ map skolemiseSubst substs0
hsc_ic' = foldr (flip substInteractiveContext)
(extendInteractiveContext (hsc_IC hsc_env) [] (unionVarSets skol_vars))
substs
in hsc_env{hsc_IC = hsc_ic'}
-- Finally, print the Terms
unqual <- GHC.getPrintUnqual
docterms <- mapM showTerm terms
......@@ -68,13 +70,12 @@ pprintClosureCommand bindThings force str = do
ids
docterms)
where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
go :: GhcMonad m => Id -> m (Term, TvSubst)
go id = do
term_ <- GHC.obtainTerm force 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
......@@ -84,6 +85,11 @@ pprintClosureCommand bindThings force str = do
let reconstructed_type = termType term
mb_subst <- withSession $ \hsc_env ->
liftIO $ improveRTTIType hsc_env (idType id) (reconstructed_type)
maybe (return ())
(\subst -> traceOptIf Opt_D_dump_rtti
(fsep $ [text "RTTI Improvement for", ppr id,
text "is the substitution:" , ppr subst]))
mb_subst
return (term', fromMaybe emptyTvSubst mb_subst)
tidyTermTyVars :: GhcMonad m => Term -> m Term
......@@ -110,11 +116,10 @@ bindSuspensions t = do
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
(tys', skol_vars) = unzip $ map 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
new_ic = extendInteractiveContext ictxt ids (unionVarSets skol_vars)
liftIO $ extendLinkEnv (zip names hvals)
modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
return t'
......@@ -194,7 +199,7 @@ showTerm term = do
name <- newGrimName userName
let ictxt = hsc_IC hsc_env
tmp_ids = ic_tmp_ids ictxt
id = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
id = mkGlobalId VanillaGlobal name ty vanillaIdInfo
new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
return (hsc_env {hsc_IC = new_ic }, name)
......@@ -215,9 +220,17 @@ pprTypeAndContents ids = do
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
This diff is collapsed.
......@@ -145,6 +145,7 @@ data DynFlag
| Opt_D_dump_BCOs
| Opt_D_dump_vect
| Opt_D_dump_hpc
| Opt_D_dump_rtti
| Opt_D_source_stats
| Opt_D_verbose_core2core
| Opt_D_verbose_stg2stg
......@@ -1357,6 +1358,8 @@ dynamic_flags = [
Supported
, Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs)
Supported
, Flag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti)
Supported
, Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting))
Supported
......
......@@ -106,7 +106,7 @@ module GHC (
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
lookupName,
GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
......@@ -2555,18 +2555,14 @@ getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
obtainTerm :: GhcMonad m => Bool -> Id -> m Term
obtainTerm force id = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTerm hsc_env force id
obtainTerm1 :: GhcMonad m => Bool -> Maybe Type -> a -> m Term
obtainTerm1 force mb_ty a =
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound force ty a =
withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermB :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermB bound force id =
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId bound force id =
withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermB hsc_env bound force id
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
......@@ -1089,11 +1089,11 @@ extendInteractiveContext
-> TyVarSet
-> InteractiveContext
extendInteractiveContext ictxt ids tyvars
= ictxt { ic_tmp_ids = ic_tmp_ids ictxt ++ ids,
= ictxt { ic_tmp_ids = snub((ic_tmp_ids ictxt \\ ids) ++ ids),
-- NB. must be this way around, because we want
-- new ids to shadow existing bindings.
ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars }
where snub = map head . group . sort
substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
......
......@@ -30,7 +30,7 @@ module InteractiveEval (
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where
......@@ -83,6 +83,7 @@ import Exception
import Control.Concurrent
import Data.List (sortBy)
import Foreign.StablePtr
import System.IO
-- -----------------------------------------------------------------------------
-- running a statement interactively
......@@ -637,26 +638,46 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
incompletelyTypedIds =
[id | id <- tmp_ids
, not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
, isSkolemTyVar v]
, not $ noSkolems id
, (occNameFS.nameOccName.idName) id /= result_fs]
tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
-- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
improvs <- sequence [improveRTTIType hsc_env ty ty'
| (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
let ic' = foldr (\mb_subst ic' ->
maybe (WARN(True, text ("RTTI failed to calculate the "
++ "improvement for a type")) ic')
(substInteractiveContext ic' . skolemiseSubst)
mb_subst)
ic
improvs
return hsc_env{hsc_IC=ic'}
skolemiseSubst :: TvSubst -> TvSubst
skolemiseSubst subst = subst `setTvSubstEnv`
mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
return hsc_env'
where
noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
Just id = find (\i -> idName i == name) tmp_ids
if noSkolems id
then return hsc_env
else do
mb_new_ty <- reconstructType hsc_env 10 id
let old_ty = idType id
case mb_new_ty of
Nothing -> return hsc_env
Just new_ty -> do
mb_subst <- improveRTTIType hsc_env old_ty new_ty
case mb_subst of
Nothing -> return $
WARN(True, text (":print failed to calculate the "
++ "improvement for a type")) hsc_env
Just subst -> do
when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
printForUser stderr alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
let (subst', skols) = skolemiseSubst subst
ic' = extendInteractiveContext
(substInteractiveContext ic subst') [] skols
return hsc_env{hsc_IC=ic'}
skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
skolemiseSubst subst = let
varenv = getTvSubstEnv subst
all_together = mapVarEnv skolemiseTy varenv
(varenv', skol_vars) = ( mapVarEnv fst all_together
, map snd (varEnvElts all_together))
in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
skolemiseTy :: Type -> (Type, TyVarSet)
skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
......@@ -969,23 +990,20 @@ isModuleInterpreted mod_summary = withSession $ \hsc_env ->
----------------------------------------------------------------------------
-- RTTI primitives
obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
obtainTerm1 hsc_env force mb_ty x =
cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal hsc_env bound force ty x =
cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermB hsc_env bound force id = do
hv <- Linker.getHValue hsc_env (varName id)
cvObtainTerm hsc_env bound force (Just$ idType id) hv
obtainTerm :: HscEnv -> Bool -> Id -> IO Term
obtainTerm hsc_env force id = do
hv <- Linker.getHValue hsc_env (varName id)
cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
hv <- Linker.getHValue hsc_env (varName id)
cvObtainTerm hsc_env bound force (idType id) hv
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (Just$ idType id) hv
cvReconstructType hsc_env bound (idType id) hv
#endif /* GHCI */
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment