diff options
| -rw-r--r-- | compiler/iface/BinIface.hs | 9 | ||||
| -rw-r--r-- | compiler/iface/LoadIface.lhs | 5 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 158 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 77 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 66 |
5 files changed, 235 insertions, 80 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 502eefa578..211417debb 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -390,7 +390,8 @@ instance Binary ModIface where mi_rules = rules, mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, - mi_hpc = hpc_info }) = do + mi_hpc = hpc_info, + mi_trust = trust }) = do put_ bh mod put_ bh is_boot put_ bh iface_hash @@ -411,6 +412,7 @@ instance Binary ModIface where put_ bh orphan_hash put_ bh vect_info put_ bh hpc_info + put_ bh trust get bh = do mod_name <- get bh @@ -433,6 +435,7 @@ instance Binary ModIface where orphan_hash <- get bh vect_info <- get bh hpc_info <- get bh + trust <- get bh return (ModIface { mi_module = mod_name, mi_boot = is_boot, @@ -455,6 +458,7 @@ instance Binary ModIface where mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, mi_hpc = hpc_info, + mi_trust = trust, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, @@ -1522,4 +1526,7 @@ instance Binary IfaceVectInfo where a5 <- get bh return (IfaceVectInfo a1 a2 a3 a4 a5) +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 97acc5226a..ccaaf6928a 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -666,7 +666,9 @@ pprModIface iface , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) , pprVectInfo (mi_vect_info iface) + , pprVectInfo (mi_vect_info iface) , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) ] where pp_boot | mi_boot iface = ptext (sLit "[boot]") @@ -743,6 +745,9 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons) ] +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust + instance Outputable Warnings where ppr = pprWarns diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0bce56bd14..9deceb53b9 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -106,24 +106,24 @@ import System.FilePath %************************************************************************ -%* * +%* * \subsection{Completing an interface} -%* * +%* * %************************************************************************ \begin{code} mkIface :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it - -> ModDetails -- The trimmed, tidied interface - -> ModGuts -- Usages, deprecations, etc - -> IO (Messages, + -> Maybe Fingerprint -- The old fingerprint, if we have it + -> ModDetails -- The trimmed, tidied interface + -> ModGuts -- Usages, deprecations, etc + -> IO (Messages, Maybe (ModIface, -- The new one - Bool)) -- True <=> there was an old Iface, and the + Bool)) -- True <=> there was an old Iface, and the -- new one is identical, so no need -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, + ModGuts{ mg_module = this_mod, mg_boot = is_boot, mg_used_names = used_names, mg_deps = deps, @@ -232,6 +232,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 + ; trust_info = (setSafeMode . safeHaskell . hsc_dflags) hsc_env ; intermediate_iface = ModIface { mi_module = this_mod, @@ -264,6 +265,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_decls = deliberatelyOmitted "decls", mi_hash_fn = deliberatelyOmitted "hash_fn", mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, @@ -1029,53 +1031,50 @@ checkOldIface :: HscEnv -> IO (RecompileRequired, Maybe ModIface) checkOldIface hsc_env mod_summary source_unchanged maybe_iface - = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ - showSDoc (ppr (ms_mod mod_summary))) ; - - ; initIfaceCheck hsc_env $ - check_old_iface hsc_env mod_summary source_unchanged maybe_iface - } + = do showPass (hsc_dflags hsc_env) $ + "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary) + initIfaceCheck hsc_env $ + check_old_iface hsc_env mod_summary source_unchanged maybe_iface check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface -> IfG (Bool, Maybe ModIface) -check_old_iface hsc_env mod_summary source_unchanged maybe_iface - = do -- CHECK WHETHER THE SOURCE HAS CHANGED - { when (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - ; let dflags = hsc_dflags hsc_env - ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then - return (outOfDate, maybe_iface) - else - case maybe_iface of { - Just old_iface -> do -- Use the one we already have - { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) - ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface - ; return (recomp, Just old_iface) } - - ; Nothing -> do - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - { let iface_path = msHiFilePath mod_summary - ; read_result <- readIface (ms_mod mod_summary) iface_path False - ; case read_result of { - Failed err -> do -- Old interface file not found, or garbled; give up - { traceIf (text "FYI: cannot read old interface file:" - $$ nest 4 err) - ; return (outOfDate, Nothing) } - - ; Succeeded iface -> do - - -- We have got the old iface; check its versions - { traceIf (text "Read the interface file" <+> text iface_path) - ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface - ; return (recomp, Just iface) - }}}}} - +check_old_iface hsc_env mod_summary src_unchanged maybe_iface + = let src_changed = not src_unchanged + dflags = hsc_dflags hsc_env + getIface = + case maybe_iface of + Just _ -> do + traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> do + let iface_path = msHiFilePath mod_summary + read_result <- readIface (ms_mod mod_summary) iface_path False + case read_result of + Failed err -> do + traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err) + return Nothing + Succeeded iface -> do + traceIf (text "Read the interface file" <+> text iface_path) + return $ Just iface + + in do + when src_changed + (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) + + -- If the source has changed and we're in interactive mode, avoid reading + -- an interface; just return the one we might have been supplied with. + if not (isObjectTarget $ hscTarget dflags) && src_changed + then return (outOfDate, maybe_iface) + else do + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + maybe_iface' <- getIface + case maybe_iface' of + Nothing -> return (outOfDate, maybe_iface') + Just iface -> do + -- We have got the old iface; check its versions + recomp <- checkVersions hsc_env src_unchanged mod_summary iface + return recomp \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -1089,41 +1088,50 @@ upToDate, outOfDate :: Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required +-- | Check the safe haskell flags haven't changed +-- (e.g different flag on command line now) +checkSafeHaskell :: HscEnv -> ModIface -> Bool +checkSafeHaskell hsc_env iface + = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env) + checkVersions :: HscEnv -> Bool -- True <=> source unchanged -> ModSummary -> ModIface -- Old interface - -> IfG RecompileRequired + -> IfG (RecompileRequired, Maybe ModIface) checkVersions hsc_env source_unchanged mod_summary iface | not source_unchanged - = return outOfDate + = return (outOfDate, Just iface) | otherwise - = do { traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) ; recomp <- checkDependencies hsc_env mod_summary iface - ; if recomp then return outOfDate else do { + ; if recomp then return (outOfDate, Just iface) else do { + ; if trust_dif then return (outOfDate, Nothing) else do { - -- Source code unchanged and no errors yet... carry on + -- Source code unchanged and no errors yet... carry on -- - -- First put the dependent-module info, read from the old - -- interface, into the envt, so that when we look for - -- interfaces we look for the right one (.hi or .hi-boot) - -- - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - -- - -- We do this regardless of compilation mode, although in --make mode - -- all the dependent modules should be in the HPT already, so it's - -- quite redundant - updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - - ; let this_pkg = thisPackage (hsc_dflags hsc_env) - ; checkList [checkModUsage this_pkg u | u <- mi_usages iface] - }} + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + -- + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant + updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + + ; let this_pkg = thisPackage (hsc_dflags hsc_env) + ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; return (recomp, Just iface) + }}} where - -- This is a bit of a hack really + trust_dif = checkSafeHaskell hsc_env iface + -- This is a bit of a hack really mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 167177703e..f25df2d5f1 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -31,6 +31,7 @@ module DynFlags ( fFlags, fLangFlags, xFlags, DPHBackend(..), dphPackageMaybe, wayNames, + SafeHaskellMode(..), Settings(..), ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, @@ -319,6 +320,24 @@ data DynFlag data Language = Haskell98 | Haskell2010 +-- | The various SafeHaskell modes +data SafeHaskellMode + = Sf_None + | Sf_SafeImports + | Sf_SafeLanguage + | Sf_Trustworthy + | Sf_TrustworthyWithSafeLanguage + | Sf_Safe + deriving (Eq) + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_SafeImports = "SafeImports" + show Sf_SafeLanguage = "SafeLanguage" + show Sf_Trustworthy = "Trustworthy" + show Sf_TrustworthyWithSafeLanguage = "Trustworthy + SafeLanguage" + show Sf_Safe = "Safe" + data ExtensionFlag = Opt_Cpp | Opt_OverlappingInstances @@ -511,6 +530,8 @@ data DynFlags = DynFlags { flags :: [DynFlag], -- Don't change this without updating extensionFlags: language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, -- Don't change this without updating extensionFlags: extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to @@ -831,6 +852,7 @@ defaultDynFlags mySettings = haddockOptions = Nothing, flags = defaultFlags, language = Nothing, + safeHaskell = Sf_None, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], @@ -949,6 +971,47 @@ setLanguage l = upd f extensionFlags = flattenExtensionFlags mLang oneoffs } +-- | Set a 'SafeHaskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = upd f + where f dfs = let sf = safeHaskell dfs + in dfs { + safeHaskell = combineSafeFlags sf s + } + +-- | Combine two SafeHaskell modes correctly. Used for dealing with multiple flags. +-- This makes SafeHaskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> SafeHaskellMode +combineSafeFlags a b = + case (a,b) of + (Sf_None, sf) -> sf + (sf, Sf_None) -> sf + + (Sf_SafeImports, sf) -> sf + (sf, Sf_SafeImports) -> sf + + (Sf_SafeLanguage, Sf_Safe) -> err + (Sf_Safe, Sf_SafeLanguage) -> err + + (Sf_SafeLanguage, Sf_Trustworthy) -> Sf_TrustworthyWithSafeLanguage + (Sf_Trustworthy, Sf_SafeLanguage) -> Sf_TrustworthyWithSafeLanguage + + (Sf_TrustworthyWithSafeLanguage, Sf_Trustworthy) -> Sf_TrustworthyWithSafeLanguage + (Sf_TrustworthyWithSafeLanguage, Sf_SafeLanguage) -> Sf_TrustworthyWithSafeLanguage + (Sf_Trustworthy, Sf_TrustworthyWithSafeLanguage) -> Sf_TrustworthyWithSafeLanguage + (Sf_SafeLanguage, Sf_TrustworthyWithSafeLanguage) -> Sf_TrustworthyWithSafeLanguage + + (Sf_Trustworthy, Sf_Safe) -> err + (Sf_Safe, Sf_Trustworthy) -> err + + (a,b) | a == b -> a + | otherwise -> err + + where err = ghcError (CmdLineError $ "Incompatible SafeHaskell flags! (" + ++ show a ++ "," ++ show b ++ ")") + -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors @@ -1467,6 +1530,7 @@ dynamic_flags = [ ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags ++ map (mkFlag turnOn "X" setLanguage) languageFlags + ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ @@ -1645,11 +1709,15 @@ fLangFlags = [ supportedLanguages :: [String] supportedLanguages = [ name | (name, _, _) <- languageFlags ] +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = [ name | (name, _, _) <- safeHaskellFlags ] + supportedExtensions :: [String] supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] supportedLanguagesAndExtensions :: [String] -supportedLanguagesAndExtensions = supportedLanguages ++ supportedExtensions +supportedLanguagesAndExtensions = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions -- | These -X<blah> flags cannot be reversed with -XNo<blah> languageFlags :: [FlagSpec Language] @@ -1658,6 +1726,13 @@ languageFlags = [ ( "Haskell2010", Haskell2010, nop ) ] +-- | These -X<blah> flags cannot be reversed with -XNo<blah> +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlags :: [FlagSpec SafeHaskellMode] +safeHaskellFlags = map mkF [Sf_SafeImports, Sf_SafeLanguage, Sf_Trustworthy, Sf_Safe] + where mkF flag = (show flag, flag, nop) + -- | These -X<blah> flags can all be reversed with -XNo<blah> xFlags :: [FlagSpec ExtensionFlag] xFlags = [ diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index ea0cd6357b..d39e1daa12 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -91,6 +91,10 @@ module HscTypes ( VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, noIfaceVectInfo, + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, + -- * Compilation errors and warnings SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, throwOneError, handleSourceError, @@ -127,7 +131,7 @@ import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..) ) + DynFlag(..), SafeHaskellMode(..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -154,6 +158,7 @@ import Data.IORef import Data.Array ( Array, array ) import Data.List import Data.Map (Map) +import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception @@ -680,8 +685,10 @@ data ModIface -- isn't in decls. It's useful to know that when -- seeing if we are up to date wrt. the old interface. -- The 'OccName' is the parent of the name, if it has one. - mi_hpc :: !AnyHpcUsage + mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. + mi_trust :: !IfaceTrustInfo + -- ^ Safe Haskell Trust information for this module. } -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' @@ -852,7 +859,8 @@ emptyModIface mod mi_warn_fn = emptyIfaceWarnCache, mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache, - mi_hpc = False + mi_hpc = False, + mi_trust = noIfaceTrustInfo } \end{code} @@ -1794,6 +1802,58 @@ noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] %************************************************************************ %* * +\subsection{Safe Haskell Support} +%* * +%************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. + +\begin{code} +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_SafeImports -> 1 + Sf_SafeLanguage -> 2 + Sf_Trustworthy -> 3 + Sf_TrustworthyWithSafeLanguage -> 4 + Sf_Safe -> 5 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_SafeImports +numToTrustInfo 2 = setSafeMode Sf_SafeLanguage +numToTrustInfo 3 = setSafeMode Sf_Trustworthy +numToTrustInfo 4 = setSafeMode Sf_TrustworthyWithSafeLanguage +numToTrustInfo 5 = setSafeMode Sf_Safe +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = ptext $ sLit "none" + ppr (TrustInfo Sf_SafeImports) = ptext $ sLit "safe-imports" + ppr (TrustInfo Sf_SafeLanguage) = ptext $ sLit "safe-language" + ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" + ppr (TrustInfo Sf_TrustworthyWithSafeLanguage) + = ptext $ sLit "trustworthy + safe-language" + ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" +\end{code} + +%************************************************************************ +%* * \subsection{Linkable stuff} %* * %************************************************************************ |