diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 99f4d53873e2afbd1f417e67246f35fb0e84ae06..e6575b66fb0a0584ba11b07b54dff3983e643bd5 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -20,6 +20,7 @@ import StaticFlags import HscTypes import HsSyn import TcRnTypes +import TcRnMonad ( finalSafeMode ) import MkIface import Id import Name @@ -169,6 +170,7 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files + ; safe_mode <- finalSafeMode dflags tcg_env ; let mod_guts = ModGuts { mg_module = mod, @@ -194,6 +196,7 @@ deSugar hsc_env mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, mg_vect_info = noVectInfo, + mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, mg_dependent_files = dep_files } diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7999519280eaa493bf4fca2ab72c4f40be2ab284..560749d325110c46f7913a17d3d578b732bffd54 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -133,32 +133,35 @@ mkIface :: HscEnv -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_used_names = used_names, - mg_used_th = used_th, - mg_deps = deps, - mg_dir_imps = dir_imp_mods, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info, - mg_trust_pkg = self_trust, + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_used_th = used_th, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_safe_haskell = safe_mode, + mg_trust_pkg = self_trust, mg_dependent_files = dependent_files } = mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names used_th deps rdr_env fix_env - warns hpc_info dir_imp_mods self_trust dependent_files mod_details + warns hpc_info dir_imp_mods self_trust dependent_files + safe_mode mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). mkIfaceTc :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it + -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc -> IO (Messages, Maybe (ModIface, Bool)) -mkIfaceTc hsc_env maybe_old_fingerprint mod_details +mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -178,7 +181,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details mkIface_ hsc_env maybe_old_fingerprint this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env fix_env warns hpc_info (imp_mods imports) - (imp_trust_own_pkg imports) dep_files mod_details + (imp_trust_own_pkg imports) dep_files safe_mode mod_details mkUsedNames :: TcGblEnv -> NameSet @@ -224,11 +227,12 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> Bool -> [FilePath] + -> SafeHaskellMode -> ModDetails -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names used_th deps rdr_env fix_env src_warns - hpc_info dir_imp_mods pkg_trust_req dependent_files + hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -242,7 +246,6 @@ mkIface_ hsc_env maybe_old_fingerprint -- to expose in the interface = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files - ; safeInf <- hscGetSafeInf hsc_env ; let { entities = typeEnvElts type_env ; decls = [ tyThingToIfaceDecl entity @@ -261,12 +264,7 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info - -- Check if we are in Safe Inference mode but we failed to pass - -- the muster - ; safeMode = if safeInferOn dflags && not safeInf - then Sf_None - else safeHaskell dflags - ; trust_info = setSafeMode safeMode + ; trust_info = setSafeMode safe_mode ; intermediate_iface = ModIface { mi_module = this_mod, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9665c60f2fc0a3619fbf7d362911265b90ead925..730c917947fe542cb1a707103e904714f7a012c2 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -78,10 +78,12 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, modInfoIface, + modInfoSafe, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), + SafeHaskellMode(..), -- * Querying the environment packageDbModules, @@ -260,6 +262,7 @@ import HscMain import GhcMake import DriverPipeline ( compile' ) import GhcMonad +import TcRnMonad ( finalSafeMode ) import TcRnTypes import Packages import NameSet @@ -696,6 +699,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), @@ -708,7 +712,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 @@ -782,12 +787,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 @@ -824,7 +833,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, @@ -843,7 +852,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 @@ -861,7 +870,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 @@ -878,18 +887,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 } -- %************************************************************************ @@ -936,9 +949,10 @@ data ModuleInfo = ModuleInfo { minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [Instance], - 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 @@ -979,6 +993,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 @@ -999,7 +1014,8 @@ getHomeModuleInfo hsc_env mdl = minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details, - minf_iface = Just iface + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif @@ -1044,6 +1060,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 diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f8e2b5df26530646645344b8071c380c8848fb79..88be2edfaa1bbafa5d9150bda7495a36ba627c30 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -169,7 +169,6 @@ newHscEnv dflags = do fc_var <- newIORef emptyUFM mlc_var <- newIORef emptyModuleEnv optFuel <- initOptFuelState - safe_var <- newIORef True return HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], @@ -180,8 +179,7 @@ newHscEnv dflags = do hsc_FC = fc_var, hsc_MLC = mlc_var, hsc_OptFuel = optFuel, - hsc_type_env_var = Nothing, - hsc_safeInf = safe_var } + hsc_type_env_var = Nothing } knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, @@ -388,10 +386,7 @@ type RenamedStuff = hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) - True rdr_module + tc_result <- tcRnModule' hsc_env mod_summary True rdr_module -- This 'do' is in the Maybe monad! let rn_info = do decl <- tcg_rn_decls tc_result @@ -402,6 +397,35 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do return (tc_result, rn_info) +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' hsc_env sum save_rn_syntax mod = do + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod + + tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) + dflags <- getDynFlags + + -- end of the Safe Haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) + -- if safe haskell off or safe infer failed, wipe trust + then wipeTrust tcg_res emptyBag + + -- module safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') + when (safe && wopt Opt_WarnSafe dflags) + (logWarnings $ unitBag $ + mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res') + return tcg_res' + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = text "Warning:" <+> quotes (pprMod t) + <+> text "has been infered as safe!" + -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts hscDesugar hsc_env mod_summary tc_result = @@ -426,9 +450,11 @@ hscDesugar' mod_location tc_result = do -- we should use fingerprint versions instead. makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) -makeSimpleIface hsc_env maybe_old_iface tc_result details = - runHsc hsc_env $ ioMsgMaybe $ - mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result +makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do + safe_mode <- hscGetSafeMode tc_result + ioMsgMaybe $ do + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode + details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. @@ -528,7 +554,7 @@ data HsCompiler a = HsCompiler { -> Hsc a, -- | Code generation for normal modules. - hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint + hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint -> Hsc a } @@ -818,31 +844,8 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv hscFileFrontEnd mod_summary = do hpm <- hscParse' mod_summary hsc_env <- getHscEnv - dflags <- getDynFlags - tcg_env <- - {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm - tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env) - - -- end of the Safe Haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) - - -- if safe haskell off or safe infer failed, wipe trust - then wipeTrust tcg_env emptyBag - - -- module safe, throw warning if needed - else do - tcg_env' <- hscCheckSafeImports tcg_env - safe <- liftIO $ hscGetSafeInf hsc_env - when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ - mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env') - return tcg_env' - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = text "Warning:" <+> quotes (pprMod t) - <+> text "has been infered as safe!" + tcg_env <- tcRnModule' hsc_env mod_summary False hpm + return tcg_env -------------------------------------------------------------- -- Safe Haskell @@ -1091,14 +1094,13 @@ checkPkgTrust dflags pkgs = -- it should be a central and single failure method. wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv wipeTrust tcg_env whyUnsafe = do - env <- getHscEnv dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) (logWarnings $ unitBag $ mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - liftIO $ hscSetSafeInf env False + liftIO $ writeIORef (tcg_safeInfer tcg_env) False return $ tcg_env { tcg_imports = wiped_trust } where @@ -1116,6 +1118,12 @@ wipeTrust tcg_env whyUnsafe = do text str <+> text "is not allowed in Safe Haskell"] | otherwise = [] +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env + -------------------------------------------------------------- -- Simplifiers -------------------------------------------------------------- @@ -1137,12 +1145,13 @@ hscSimpleIface :: TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails) hscSimpleIface tc_result mb_old_iface = do - hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} ioMsgMaybe $ - mkIfaceTc hsc_env mb_old_iface details tc_result + mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, no_change, details) @@ -1564,21 +1573,23 @@ hscParseThingWithLocation source linenumber parser str liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) return thing -hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO () -hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do - guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) - (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing - hscWriteIface iface changed mod_summary - _ <- hscGenHardCode cgguts mod_summary - return () +hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary + -> CoreProgram -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds + = runHsc hsc_env $ do + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) + (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing + hscWriteIface iface changed mod_summary + _ <- hscGenHardCode cgguts mod_summary + return () where maybe_simplify mod_guts | simplify = hscSimplify' mod_guts | otherwise = return mod_guts -- Makes a "vanilla" ModGuts. -mkModGuts :: Module -> CoreProgram -> ModGuts -mkModGuts mod binds = +mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts +mkModGuts mod safe binds = ModGuts { mg_module = mod, mg_boot = False, @@ -1603,6 +1614,7 @@ mkModGuts mod binds = mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, mg_fam_inst_env = emptyFamInstEnv, + mg_safe_haskell = safe, mg_trust_pkg = False, mg_dependent_files = [] } diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index a9f3f694b2762e91f6432fa2c8246aec9d060565..d457a3dbcb2a550a87ee8e4b5b4125fdafa36822 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -95,7 +95,6 @@ module HscTypes ( noIfaceVectInfo, isNoIfaceVectInfo, -- * Safe Haskell information - hscGetSafeInf, hscSetSafeInf, IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, trustInfoToNum, numToTrustInfo, IsSafeImport, @@ -324,24 +323,12 @@ data HscEnv -- by limiting the number of transformations, -- we can use binary search to help find compiler bugs. - hsc_type_env_var :: Maybe (Module, IORef TypeEnv), + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRunTypes.TcGblEnv' - - hsc_safeInf :: {-# UNPACK #-} !(IORef Bool) - -- ^ Have we infered the module being compiled as - -- being safe? } --- | Get if the current module is considered safe or not by inference. -hscGetSafeInf :: HscEnv -> IO Bool -hscGetSafeInf hsc_env = readIORef (hsc_safeInf hsc_env) - --- | Set if the current module is considered safe or not by inference. -hscSetSafeInf :: HscEnv -> Bool -> IO () -hscSetSafeInf hsc_env b = writeIORef (hsc_safeInf hsc_env) b - -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) @@ -842,6 +829,8 @@ data ModGuts mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_safe_haskell :: SafeHaskellMode, + -- ^ Safe Haskell mode mg_trust_pkg :: Bool, -- ^ Do we need to trust our own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 48799743870952c7e807c9ea5985c8d056f075f9..e8ffb8b3c60633261307962e53bbe771d28fad16 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -346,6 +346,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; + safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ; dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; setGblEnv tcg_env $ do { @@ -361,32 +362,33 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? - mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, - mg_used_names = emptyNameSet, -- ToDo: compute usage - mg_used_th = False, - mg_dir_imps = emptyModuleEnv, -- ?? - mg_deps = noDependencies, -- ?? - mg_exports = my_exports, - mg_tcs = tcg_tcs tcg_env, - mg_insts = tcg_insts tcg_env, - mg_fam_insts = tcg_fam_insts tcg_env, - mg_inst_env = tcg_inst_env tcg_env, + mod_guts = ModGuts { mg_module = this_mod, + mg_boot = False, + mg_used_names = emptyNameSet, -- ToDo: compute usage + mg_used_th = False, + mg_dir_imps = emptyModuleEnv, -- ?? + mg_deps = noDependencies, -- ?? + mg_exports = my_exports, + mg_tcs = tcg_tcs tcg_env, + mg_insts = tcg_insts tcg_env, + mg_fam_insts = tcg_fam_insts tcg_env, + mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, - mg_rules = [], - mg_vect_decls = [], - mg_anns = [], - mg_binds = core_binds, + mg_rules = [], + mg_vect_decls = [], + mg_anns = [], + mg_binds = core_binds, -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_warns = NoWarnings, - mg_foreign = NoStubs, - mg_hpc_info = emptyHpcInfo False, - mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo, - mg_trust_pkg = False, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_warns = NoWarnings, + mg_foreign = NoStubs, + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_safe_haskell = safe_mode, + mg_trust_pkg = False, mg_dependent_files = dep_files } } ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 381d5355d1f43a01393b1300eac88b6925642df4..c4e997296eb9094bd1917ff7b5b8ce0d5ec0a1ed 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1104,8 +1104,17 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ \begin{code} +-- | Mark that safe inference has failed recordUnsafeInfer :: TcM () recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- readIORef (tcg_safeInfer tcg_env) + return $ if safeInferOn dflags && not safeInf + then Sf_None + else safeHaskell dflags \end{code}