Fix GHC API with respect to safe haskell. (#5989)

This fixes haddock so it correctly reports
the safe haskell mode of a module.

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
               }

compiler/iface/MkIface.lhs

@@ -135,32 +135,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,
@@ -180,7 +183,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
@@ -226,11 +229,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,
@@ -244,7 +248,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
@@ -263,13 +266,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,

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  

compiler/main/HscMain.hs

@@ -171,7 +171,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    = [],
@@ -182,8 +181,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,
@@ -405,10 +403,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
@@ -419,6 +414,34 @@ 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 = 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 =
@@ -443,9 +466,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.
@@ -545,7 +570,7 @@ data HsCompiler a = HsCompiler {
                      -> Hsc a,
 
     -- | Code generation for normal modules.
-    hscGenOutput :: ModGuts  -> ModSummary -> Maybe Fingerprint
+    hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint
                  -> Hsc a
   }
 
@@ -836,30 +861,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 = quotes (pprMod t) <+> text "has been infered as safe!"
+    tcg_env <- tcRnModule' hsc_env mod_summary False hpm
+    return tcg_env
 
 --------------------------------------------------------------
 -- Safe Haskell
@@ -1124,14 +1127,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
@@ -1148,6 +1150,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
 --------------------------------------------------------------
@@ -1169,12 +1177,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)
@@ -1588,21 +1597,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,
@@ -1627,6 +1638,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 = []
     }

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]

compiler/typecheck/TcRnDriver.lhs

@@ -339,6 +339,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 {
@@ -366,20 +367,21 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                 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
                             } } ;
 

compiler/typecheck/TcRnMonad.lhs

@@ -1112,8 +1112,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}