Skip to content
GitLab
Commit 5a0b8270 authored by dterei's avatar dterei
Browse files

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

This fixes haddock so it correctly reports
the safe haskell mode of a module.
parent 7ed67597
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/Desugar.lhs
View file @ 5a0b8270
......@@ -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
View file @ 5a0b8270
......@@ -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
View file @ 5a0b8270
......@@ -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
View file @ 5a0b8270
......@@ -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
View file @ 5a0b8270
......@@ -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
View file @ 5a0b8270
......@@ -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
View file @ 5a0b8270
......@@ -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}
......
Supports Markdown
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