Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
79407817
Commit
79407817
authored
Oct 31, 2011
by
dterei
Browse files
safe haskell wip
parent
9241aa0b
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/main/DynFlags.hs
View file @
79407817
...
...
@@ -1037,12 +1037,6 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe
safeInferOn
::
DynFlags
->
Bool
safeInferOn
dflags
=
safeHaskell
dflags
==
Sf_SafeInfered
-- | Turn off Safe Haskell inference mode (set module to unsafe)
setSafeInferOff
::
DynFlags
->
DynFlags
setSafeInferOff
dflags
|
safeHaskell
dflags
==
Sf_SafeInfered
=
dflags
{
safeHaskell
=
Sf_None
}
|
otherwise
=
dflags
-- | Test if Safe Imports are on in some form
safeImportsOn
::
DynFlags
->
Bool
safeImportsOn
dflags
=
safeHaskell
dflags
==
Sf_Unsafe
||
...
...
compiler/main/HscMain.lhs
View file @
79407817
...
...
@@ -161,12 +161,13 @@ import Data.IORef
\begin{code}
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = do
{ eps_var <- newIORef initExternalPackageState
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
; fc_var <- newIORef emptyUFM
; mlc_var <- newIORef emptyModuleEnv
; optFuel <- initOptFuelState
{ eps_var <- newIORef initExternalPackageState
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
; fc_var <- newIORef emptyUFM
; mlc_var <- newIORef emptyModuleEnv
; optFuel <- initOptFuelState
; safe_var <- newIORef True
; return (HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
...
...
@@ -177,7 +178,8 @@ newHscEnv dflags = do
hsc_FC = fc_var,
hsc_MLC = mlc_var,
hsc_OptFuel = optFuel,
hsc_type_env_var = Nothing } ) }
hsc_type_env_var = Nothing,
hsc_safeInf = safe_var } ) }
knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
...
...
@@ -191,40 +193,37 @@ knownKeyNames = -- where templateHaskellNames are defined
-- -----------------------------------------------------------------------------
-- The Hsc monad: Passing an enviornment and warning state
newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages
, HscEnv
))
newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
instance Monad Hsc where
return a = Hsc $ \
e
w -> return (a, w
, e
)
Hsc m >>= k = Hsc $ \e w -> do (a, w1
, e1
) <- m e w
return a = Hsc $ \
_
w -> return (a, w)
Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
case k a of
Hsc k' -> k' e
1
w1
Hsc k' -> k' e w1
instance MonadIO Hsc where
liftIO io = Hsc $ \
e
w -> do a <- io; return (a, w
, e
)
liftIO io = Hsc $ \
_
w -> do a <- io; return (a, w)
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w
, e
) <- hsc hsc_env emptyBag
printOrThrowWarnings (hsc_dflags
e
) w
(a, w) <- hsc hsc_env emptyBag
printOrThrowWarnings (hsc_dflags
hsc_env
) w
return a
getWarnings :: Hsc WarningMessages
getWarnings = Hsc $ \
e
w -> return (w, w
, e
)
getWarnings = Hsc $ \
_
w -> return (w, w)
clearWarnings :: Hsc ()
clearWarnings = Hsc $ \
e
_
w
-> return ((), emptyBag
, e
)
clearWarnings = Hsc $ \
_
_ -> return ((), emptyBag)
logWarnings :: WarningMessages -> Hsc ()
logWarnings w = Hsc $ \
e
w0 -> return ((), w0 `unionBags` w
, e
)
logWarnings w = Hsc $ \
_
w0 -> return ((), w0 `unionBags` w)
getHscEnv :: Hsc HscEnv
getHscEnv = Hsc $ \e w -> return (e, w
, e
)
getHscEnv = Hsc $ \e w -> return (e, w)
getDynFlags :: Hsc DynFlags
getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w, e)
setDynFlags :: DynFlags -> Hsc ()
setDynFlags dflags = Hsc $ \e w -> return ((), w, e { hsc_dflags = dflags })
getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
handleWarnings :: Hsc ()
handleWarnings = do
...
...
@@ -607,7 +606,7 @@ hscOneShotCompiler =
, hscRecompile = genericHscRecompile hscOneShotCompiler
, hscBackend = \
tc_result mod_summary mb_old_hash -> do
, hscBackend = \tc_result mod_summary mb_old_hash -> do
dflags <- getDynFlags
case hscTarget dflags of
HscNothing -> return (HscRecomp Nothing ())
...
...
@@ -902,18 +901,21 @@ checkSafeImports dflags hsc_env tcg_env
logWarnings oldErrs
-- See the Note [ Safe Haskell Inference]
when (not $ isEmptyBag errs) (
-- did we fail safe inference or fail -XSafe?
case safeInferOn dflags of
True -> setDynFlags (dflags { safeHaskell = Sf_None } )
False -> liftIO . throwIO . mkSrcErr $ errs
)
when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
-- add in trusted package requirements for this module
let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
case (not $ isEmptyBag errs) of
-- We have errors!
True ->
-- did we fail safe inference or fail -XSafe?
case safeInferOn dflags of
True -> wipeTrust tcg_env
False -> liftIO . throwIO . mkSrcErr $ errs
-- All good matey!
False -> do
when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
-- add in trusted package requirements for this module
let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
where
imp_info = tcg_imports tcg_env -- ImportAvails
...
...
@@ -1029,8 +1031,8 @@ checkSafeImports dflags hsc_env tcg_env
-- | Set module to unsafe and wipe trust information.
wipeTrust :: TcGblEnv -> Hsc TcGblEnv
wipeTrust tcg_env = do
dflags
<- get
DynFlags
setDynFlags (dflags { safeHaskell = Sf_None })
env
<- get
HscEnv
liftIO $ hscSetSafeInf env False
let imps = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
return $ tcg_env { tcg_imports = imps }
...
...
compiler/main/HscTypes.lhs
View file @
79407817
...
...
@@ -95,6 +95,7 @@ module HscTypes (
noIfaceVectInfo,
-- * Safe Haskell information
hscGetSafeInf, hscSetSafeInf,
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
trustInfoToNum, numToTrustInfo, IsSafeImport,
...
...
@@ -315,12 +316,25 @@ 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)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment