diff options
Diffstat (limited to 'compiler/main/GHC.hs')
-rw-r--r-- | compiler/main/GHC.hs | 70 |
1 files changed, 45 insertions, 25 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9e33aae2bb..53320530b0 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -72,10 +72,12 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, modInfoIface, - lookupGlobalName, - findGlobalAnns, + modInfoSafe, + lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), + SafeHaskellMode(..), -- * Querying the environment packageDbModules, @@ -254,6 +256,7 @@ import HscMain import GhcMake import DriverPipeline ( compile' ) import GhcMonad +import TcRnMonad ( finalSafeMode ) import TcRnTypes import Packages import NameSet @@ -737,6 +740,7 @@ typecheckModule pmod = do HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod } details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -749,7 +753,8 @@ typecheckModule pmod = do minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), minf_instances = md_insts details, - minf_iface = Nothing + minf_iface = Nothing, + minf_safe = safe #ifdef GHCI ,minf_modBreaks = emptyModBreaks #endif @@ -823,12 +828,16 @@ data CoreModule -- | Type environment for types declared in this module cm_types :: !TypeEnv, -- | Declarations - cm_binds :: CoreProgram + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode } instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and @@ -865,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd ((moduleNameSlashes . moduleName) mName) - let modSummary = ModSummary { ms_mod = mName, + let modSum = ModSummary { ms_mod = mName, ms_hsc_src = ExtCoreFile, ms_location = modLocation, -- By setting the object file timestamp to Nothing, @@ -884,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do } hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule @@ -902,7 +911,7 @@ compileCore simplify fn = do mod_guts <- coreModule `fmap` -- TODO: space leaky: call hsc* directly? (desugarModule =<< typecheckModule =<< parseModule modSummary) - liftM gutsToCoreModule $ + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy @@ -919,18 +928,22 @@ compileCore simplify fn = do where -- two versions, based on whether we simplify (thus run tidyProgram, -- which returns a (CgGuts, ModDetails) pair, or not (in which case -- we just have a ModGuts. - gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule - gutsToCoreModule (Left (cg, md)) = CoreModule { + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode } - gutsToCoreModule (Right mg) = CoreModule { + gutsToCoreModule safe_mode (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) (mg_tcs mg) (mg_fam_insts mg), - cm_binds = mg_binds mg + cm_binds = mg_binds mg, + cm_safe = safe_mode } -- %************************************************************************ @@ -973,13 +986,14 @@ getPrintUnqual = withSession $ \hsc_env -> -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_type_env :: TypeEnv, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif } -- We don't want HomeModInfo here, because a ModuleInfo applies @@ -1020,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) #else @@ -1036,11 +1051,12 @@ getHomeModuleInfo hsc_env mdl = let details = hm_details hmi iface = hm_iface hmi return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = availsToNameSet (md_exports details), - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, - minf_iface = Just iface + minf_type_env = md_types details, + minf_exports = availsToNameSet (md_exports details), + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif @@ -1085,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks |