diff options
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 830 | ||||
-rw-r--r-- | compiler/GHC/Driver/Backpack/Syntax.hs | 83 | ||||
-rw-r--r-- | compiler/GHC/Driver/CmdLine.hs | 339 | ||||
-rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 264 | ||||
-rw-r--r-- | compiler/GHC/Driver/Finder.hs | 844 | ||||
-rw-r--r-- | compiler/GHC/Driver/Hooks.hs | 121 | ||||
-rw-r--r-- | compiler/GHC/Driver/Hooks.hs-boot | 7 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 1952 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 2739 | ||||
-rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 424 | ||||
-rw-r--r-- | compiler/GHC/Driver/Monad.hs | 204 | ||||
-rw-r--r-- | compiler/GHC/Driver/Packages.hs | 2215 | ||||
-rw-r--r-- | compiler/GHC/Driver/Packages.hs-boot | 12 | ||||
-rw-r--r-- | compiler/GHC/Driver/Phases.hs | 370 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 2340 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline/Monad.hs | 122 | ||||
-rw-r--r-- | compiler/GHC/Driver/Plugins.hs | 264 | ||||
-rw-r--r-- | compiler/GHC/Driver/Plugins.hs-boot | 10 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 5939 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs-boot | 17 | ||||
-rw-r--r-- | compiler/GHC/Driver/Types.hs | 3268 |
21 files changed, 22364 insertions, 0 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs new file mode 100644 index 0000000000..e5364e3d3f --- /dev/null +++ b/compiler/GHC/Driver/Backpack.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} + +-- | This is the driver for the 'ghc --backpack' mode, which +-- is a reimplementation of the "package manager" bits of +-- Backpack directly in GHC. The basic method of operation +-- is to compile packages and then directly insert them into +-- GHC's in memory database. +-- +-- The compilation products of this mode aren't really suitable +-- for Cabal, because GHC makes up component IDs for the things +-- it builds and doesn't serialize out the database contents. +-- But it's still handy for constructing tests. + +module GHC.Driver.Backpack (doBackpack) where + +#include "HsVersions.h" + +import GhcPrelude + +-- In a separate module because it hooks into the parser. +import GHC.Driver.Backpack.Syntax + +import ApiAnnotation +import GHC hiding (Failed, Succeeded) +import GHC.Driver.Packages +import Parser +import Lexer +import GHC.Driver.Monad +import GHC.Driver.Session +import TcRnMonad +import TcRnDriver +import Module +import GHC.Driver.Types +import StringBuffer +import FastString +import ErrUtils +import SrcLoc +import GHC.Driver.Main +import UniqFM +import UniqDFM +import Outputable +import Maybes +import HeaderInfo +import GHC.Iface.Utils +import GHC.Driver.Make +import UniqDSet +import PrelNames +import BasicTypes hiding (SuccessFlag(..)) +import GHC.Driver.Finder +import Util + +import qualified GHC.LanguageExtensions as LangExt + +import Panic +import Data.List ( partition ) +import System.Exit +import Control.Monad +import System.FilePath +import Data.Version + +-- for the unification +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map + +-- | Entry point to compile a Backpack file. +doBackpack :: [FilePath] -> Ghc () +doBackpack [src_filename] = do + -- Apply options from file to dflags + dflags0 <- getDynFlags + let dflags1 = dflags0 + src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename + (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts + modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) + -- Cribbed from: preprocessFile / GHC.Driver.Pipeline + liftIO $ checkProcessArgsResult dflags unhandled_flags + liftIO $ handleFlagWarnings dflags warns + -- TODO: Preprocessing not implemented + + buf <- liftIO $ hGetStringBuffer src_filename + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great + case unP parseBackpack (mkPState dflags buf loc) of + PFailed pst -> throwErrors (getErrorMessages pst dflags) + POk _ pkgname_bkp -> do + -- OK, so we have an LHsUnit PackageName, but we want an + -- LHsUnit HsComponentId. So let's rename it. + let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp + initBkpM src_filename bkp $ + forM_ (zip [1..] bkp) $ \(i, lunit) -> do + let comp_name = unLoc (hsunitName (unLoc lunit)) + msgTopPackage (i,length bkp) comp_name + innerBkpM $ do + let (cid, insts) = computeUnitId lunit + if null insts + then if cid == ComponentId (fsLit "main") + then compileExe lunit + else compileUnit cid [] + else typecheckUnit cid insts +doBackpack _ = + throwGhcException (CmdLineError "--backpack can only process a single file") + +computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)]) +computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) + where + cid = hsComponentId (unLoc (hsunitName unit)) + reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) + get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname + get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet + get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet + get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = + unitIdFreeHoles (convertHsUnitId hsuid) + +-- | Tiny enum for all types of Backpack operations we may do. +data SessionType + -- | A compilation operation which will result in a + -- runnable executable being produced. + = ExeSession + -- | A type-checking operation which produces only + -- interface files, no object files. + | TcSession + -- | A compilation operation which produces both + -- interface files and object files. + | CompSession + deriving (Eq) + +-- | Create a temporary Session to do some sort of type checking or +-- compilation. +withBkpSession :: ComponentId + -> [(ModuleName, Module)] + -> [(UnitId, ModRenaming)] + -> SessionType -- what kind of session are we doing + -> BkpM a -- actual action to run + -> BkpM a +withBkpSession cid insts deps session_type do_this = do + dflags <- getDynFlags + let (ComponentId cid_fs) = cid + is_primary = False + uid_str = unpackFS (hashUnitId cid insts) + cid_str = unpackFS cid_fs + -- There are multiple units in a single Backpack file, so we + -- need to separate out the results in those cases. Right now, + -- we follow this hierarchy: + -- $outputdir/$compid --> typecheck results + -- $outputdir/$compid/$unitid --> compile results + key_base p | Just f <- p dflags = f + | otherwise = "." + sub_comp p | is_primary = p + | otherwise = p </> cid_str + outdir p | CompSession <- session_type + -- Special case when package is definite + , not (null insts) = sub_comp (key_base p) </> uid_str + | otherwise = sub_comp (key_base p) + withTempSession (overHscDynFlags (\dflags -> + -- If we're type-checking an indefinite package, we want to + -- turn on interface writing. However, if the user also + -- explicitly passed in `-fno-code`, we DON'T want to write + -- interfaces unless the user also asked for `-fwrite-interface`. + -- See Note [-fno-code mode] + (case session_type of + -- Make sure to write interfaces when we are type-checking + -- indefinite packages. + TcSession | hscTarget dflags /= HscNothing + -> flip gopt_set Opt_WriteInterface + | otherwise -> id + CompSession -> id + ExeSession -> id) $ + dflags { + hscTarget = case session_type of + TcSession -> HscNothing + _ -> hscTarget dflags, + thisUnitIdInsts_ = Just insts, + thisComponentId_ = Just cid, + thisInstalledUnitId = + case session_type of + TcSession -> newInstalledUnitId cid Nothing + -- No hash passed if no instances + _ | null insts -> newInstalledUnitId cid Nothing + | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)), + -- Setup all of the output directories according to our hierarchy + objectDir = Just (outdir objectDir), + hiDir = Just (outdir hiDir), + stubDir = Just (outdir stubDir), + -- Unset output-file for non exe builds + outputFile = if session_type == ExeSession + then outputFile dflags + else Nothing, + -- Clear the import path so we don't accidentally grab anything + importPaths = [], + -- Synthesized the flags + packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> + let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) + in ExposePackage + (showSDoc dflags + (text "-unit-id" <+> ppr uid <+> ppr rn)) + (UnitIdArg uid) rn) deps + } )) $ do + dflags <- getSessionDynFlags + -- pprTrace "flags" (ppr insts <> ppr deps) $ return () + -- Calls initPackages + _ <- setSessionDynFlags dflags + do_this + +withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a +withBkpExeSession deps do_this = do + withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this + +getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) +getSource cid = do + bkp_env <- getBkpEnv + case Map.lookup cid (bkp_table bkp_env) of + Nothing -> pprPanic "missing needed dependency" (ppr cid) + Just lunit -> return lunit + +typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit cid insts = do + lunit <- getSource cid + buildUnit TcSession cid insts lunit + +compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +compileUnit cid insts = do + -- Let everyone know we're building this unit ID + msgUnitId (newUnitId cid insts) + lunit <- getSource cid + buildUnit CompSession cid insts lunit + +-- | Compute the dependencies with instantiations of a syntactic +-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a +-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@. +-- The @include_sigs@ parameter controls whether or not we also +-- include @dependency signature@ declarations in this calculation. +-- +-- Invariant: this NEVER returns InstalledUnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] +hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) + where + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) + | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] + | otherwise = [] + where + go Nothing = ModRenaming True [] + go (Just lrns) = ModRenaming False (map convRn lrns) + where + convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) + convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) + get_dep _ = [] + +buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit session cid insts lunit = do + -- NB: include signature dependencies ONLY when typechecking. + -- If we're compiling, it's not necessary to recursively + -- compile a signature since it isn't going to produce + -- any object files. + let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) + raw_deps = map fst deps_w_rns + dflags <- getDynFlags + -- The compilation dependencies are just the appropriately filled + -- in unit IDs which must be compiled before we can compile. + let hsubst = listToUFM insts + deps0 = map (renameHoleUnitId dflags hsubst) raw_deps + + -- Build dependencies OR make sure they make sense. BUT NOTE, + -- we can only check the ones that are fully filled; the rest + -- we have to defer until we've typechecked our local signature. + -- TODO: work this into GHC.Driver.Make!! + forM_ (zip [1..] deps0) $ \(i, dep) -> + case session of + TcSession -> return () + _ -> compileInclude (length deps0) (i, dep) + + dflags <- getDynFlags + -- IMPROVE IT + let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0 + + mb_old_eps <- case session of + TcSession -> fmap Just getEpsGhc + _ -> return Nothing + + conf <- withBkpSession cid insts deps_w_rns session $ do + + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph dflags (unLoc lunit) + -- pprTrace "mod_graph" (ppr mod_graph) $ return () + + msg <- mkBackpackMsg + ok <- load' LoadAllTargets (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + + let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags + export_mod ms = (ms_mod_name ms, ms_mod ms) + -- Export everything! + mods = [ export_mod ms | ms <- mgModSummaries mod_graph + , ms_hsc_src ms == HsSrcFile ] + + -- Compile relevant only + hsc_env <- getSession + let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) + linkables = map (expectJust "bkp link" . hm_linkable) + . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) + $ home_mod_infos + getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + let compat_fs = (case cid of ComponentId fs -> fs) + compat_pn = PackageName compat_fs + + return InstalledPackageInfo { + -- Stub data + abiHash = "", + sourcePackageId = SourcePackageId compat_fs, + packageName = compat_pn, + packageVersion = makeVersion [0], + unitId = toInstalledUnitId (thisPackage dflags), + sourceLibName = Nothing, + componentId = cid, + instantiatedWith = insts, + -- Slight inefficiency here haha + exposedModules = map (\(m,n) -> (m,Just n)) mods, + hiddenModules = [], -- TODO: doc only + depends = case session of + -- Technically, we should state that we depend + -- on all the indefinite libraries we used to + -- typecheck this. However, this field isn't + -- really used for anything, so we leave it + -- blank for now. + TcSession -> [] + _ -> map (toInstalledUnitId . unwireUnitId dflags) + $ deps ++ [ moduleUnitId mod + | (_, mod) <- insts + , not (isHoleModule mod) ], + abiDepends = [], + ldOptions = case session of + TcSession -> [] + _ -> obj_files, + importDirs = [ hi_dir ], + exposed = False, + indefinite = case session of + TcSession -> True + _ -> False, + -- nope + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries = [], + libraryDynDirs = [], + libraryDirs = [], + frameworks = [], + frameworkDirs = [], + ccOptions = [], + includes = [], + includeDirs = [], + haddockInterfaces = [], + haddockHTMLs = [], + trusted = False + } + + + addPackage conf + case mb_old_eps of + Just old_eps -> updateEpsGhc_ (const old_eps) + _ -> return () + +compileExe :: LHsUnit HsComponentId -> BkpM () +compileExe lunit = do + msgUnitId mainUnitId + let deps_w_rns = hsunitDeps False (unLoc lunit) + deps = map fst deps_w_rns + -- no renaming necessary + forM_ (zip [1..] deps) $ \(i, dep) -> + compileInclude (length deps) (i, dep) + withBkpExeSession deps_w_rns $ do + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph dflags (unLoc lunit) + msg <- mkBackpackMsg + ok <- load' LoadAllTargets (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + +-- | Register a new virtual package database containing a single unit +addPackage :: GhcMonad m => UnitInfo -> m () +addPackage pkg = do + dflags <- GHC.getSessionDynFlags + case pkgDatabase dflags of + Nothing -> panic "addPackage: called too early" + Just dbs -> do + let newdb = PackageDatabase + { packageDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")" + , packageDatabaseUnits = [pkg] + } + _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) }) + return () + +-- Precondition: UnitId is NOT InstalledUnitId +compileInclude :: Int -> (Int, UnitId) -> BkpM () +compileInclude n (i, uid) = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + msgInclude (i, n) uid + -- Check if we've compiled it already + case lookupUnit dflags uid of + Nothing -> do + case splitUnitIdInsts uid of + (_, Just indef) -> + innerBkpM $ compileUnit (indefUnitIdComponentId indef) + (indefUnitIdInsts indef) + _ -> return () + Just _ -> return () + +-- ---------------------------------------------------------------------------- +-- Backpack monad + +-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state +-- beyond the 'Session', c.f. 'BkpEnv'. +type BkpM = IOEnv BkpEnv + +-- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', +-- because we are going to update the 'HscEnv' as we go. +data BkpEnv + = BkpEnv { + -- | The session + bkp_session :: Session, + -- | The filename of the bkp file we're compiling + bkp_filename :: FilePath, + -- | Table of source units which we know how to compile + bkp_table :: Map ComponentId (LHsUnit HsComponentId), + -- | When a package we are compiling includes another package + -- which has not been compiled, we bump the level and compile + -- that. + bkp_level :: Int + } + +-- Blah, to get rid of the default instance for IOEnv +-- TODO: just make a proper new monad for BkpM, rather than use IOEnv +instance {-# OVERLAPPING #-} HasDynFlags BkpM where + getDynFlags = fmap hsc_dflags getSession + +instance GhcMonad BkpM where + getSession = do + Session s <- fmap bkp_session getEnv + readMutVar s + setSession hsc_env = do + Session s <- fmap bkp_session getEnv + writeMutVar s hsc_env + +-- | Get the current 'BkpEnv'. +getBkpEnv :: BkpM BkpEnv +getBkpEnv = getEnv + +-- | Get the nesting level, when recursively compiling modules. +getBkpLevel :: BkpM Int +getBkpLevel = bkp_level `fmap` getBkpEnv + +-- | Apply a function on 'DynFlags' on an 'HscEnv' +overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv +overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } + +-- | Run a 'BkpM' computation, with the nesting level bumped one. +innerBkpM :: BkpM a -> BkpM a +innerBkpM do_this = do + -- NB: withTempSession mutates, so we don't have to worry + -- about bkp_session being stale. + updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this + +-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. +updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () +updateEpsGhc_ f = do + hsc_env <- getSession + liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ())) + +-- | Get the EPS from a 'GhcMonad'. +getEpsGhc :: GhcMonad m => m ExternalPackageState +getEpsGhc = do + hsc_env <- getSession + liftIO $ readIORef (hsc_EPS hsc_env) + +-- | Run 'BkpM' in 'Ghc'. +initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a +initBkpM file bkp m = do + reifyGhc $ \session -> do + let env = BkpEnv { + bkp_session = session, + bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], + bkp_filename = file, + bkp_level = 0 + } + runIOEnv env m + +-- ---------------------------------------------------------------------------- +-- Messaging + +-- | Print a compilation progress message, but with indentation according +-- to @level@ (for nested compilation). +backpackProgressMsg :: Int -> DynFlags -> String -> IO () +backpackProgressMsg level dflags msg = + compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg + +-- | Creates a 'Messager' for Backpack compilation; this is basically +-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which +-- handles indentation. +mkBackpackMsg :: BkpM Messager +mkBackpackMsg = do + level <- getBkpLevel + return $ \hsc_env mod_index recomp mod_summary -> + let dflags = hsc_dflags hsc_env + showMsg msg reason = + backpackProgressMsg level dflags $ + showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary + ++ reason + in case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + +-- | 'PprStyle' for Backpack messages; here we usually want the module to +-- be qualified (so we can tell how it was instantiated.) But we try not +-- to qualify packages so we can use simple names for them. +backpackStyle :: DynFlags -> PprStyle +backpackStyle dflags = + mkUserStyle dflags + (QueryQualify neverQualifyNames + alwaysQualifyModules + neverQualifyPackages) AllTheWay + +-- | Message when we initially process a Backpack unit. +msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () +msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn + +-- | Message when we instantiate a Backpack unit. +msgUnitId :: UnitId -> BkpM () +msgUnitId pk = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ "Instantiating " ++ renderWithStyle + (initSDocContext dflags (backpackStyle dflags)) + (ppr pk) + +-- | Message when we include a Backpack unit. +msgInclude :: (Int,Int) -> UnitId -> BkpM () +msgInclude (i,n) uid = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ showModuleIndex (i, n) ++ "Including " ++ + renderWithStyle (initSDocContext dflags (backpackStyle dflags)) + (ppr uid) + +-- ---------------------------------------------------------------------------- +-- Conversion from PackageName to HsComponentId + +type PackageNameMap a = Map PackageName a + +-- For now, something really simple, since we're not actually going +-- to use this for anything +unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) +unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) + = (pn, HsComponentId pn (ComponentId fs)) + +packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId +packageNameMap units = Map.fromList (map unitDefines units) + +renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] +renameHsUnits dflags m units = map (fmap renameHsUnit) units + where + + renamePackageName :: PackageName -> HsComponentId + renamePackageName pn = + case Map.lookup pn m of + Nothing -> + case lookupPackageName dflags pn of + Nothing -> error "no package name" + Just cid -> HsComponentId pn cid + Just hscid -> hscid + + renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId + renameHsUnit u = + HsUnit { + hsunitName = fmap renamePackageName (hsunitName u), + hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) + } + + renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId + renameHsUnitDecl (DeclD a b c) = DeclD a b c + renameHsUnitDecl (IncludeD idecl) = + IncludeD IncludeDecl { + idUnitId = fmap renameHsUnitId (idUnitId idecl), + idModRenaming = idModRenaming idecl, + idSignatureInclude = idSignatureInclude idecl + } + + renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId + renameHsUnitId (HsUnitId ln subst) + = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) + + renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId + renameHsModuleSubst (lk, lm) + = (lk, fmap renameHsModuleId lm) + + renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId + renameHsModuleId (HsModuleVar lm) = HsModuleVar lm + renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm + +convertHsUnitId :: HsUnitId HsComponentId -> UnitId +convertHsUnitId (HsUnitId (L _ hscid) subst) + = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) + +convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) +convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) + +convertHsModuleId :: HsModuleId HsComponentId -> Module +convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname +convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname + + + +{- +************************************************************************ +* * + Module graph construction +* * +************************************************************************ +-} + +-- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications: +-- +-- 1. Every module is required to be mentioned, so we don't do any funny +-- business with targets or recursively grabbing dependencies. (We +-- could support this in principle). +-- 2. We support inline modules, whose summary we have to synthesize ourself. +-- +-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble +-- than it's worth for inline modules. +hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph +hsunitModuleGraph dflags unit = do + let decls = hsunitBody unit + pn = hsPackageName (unLoc (hsunitName unit)) + + -- 1. Create a HsSrcFile/HsigFile summary for every + -- explicitly mentioned module/signature. + let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do + Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod + get_decl _ = return Nothing + nodes <- catMaybes `fmap` mapM get_decl decls + + -- 2. For each hole which does not already have an hsig file, + -- create an "empty" hsig file to induce compilation for the + -- requirement. + let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) + | n <- nodes ] + req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) -> + let has_local = Map.member (mod_name, True) node_map + in if has_local + then return Nothing + else fmap Just $ summariseRequirement pn mod_name + + -- 3. Return the kaboodle + return $ mkModuleGraph $ nodes ++ req_nodes + +summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary +summariseRequirement pn mod_name = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + let PackageName pn_fs = pn + location <- liftIO $ mkHomeModLocation2 dflags mod_name + (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig" + + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) + + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name + + return ModSummary { + ms_mod = mod, + ms_hsc_src = HsigFile, + ms_location = location, + ms_hs_date = time, + ms_obj_date = Nothing, + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp, + ms_srcimps = [], + ms_textual_imps = extra_sig_imports, + ms_parsed_mod = Just (HsParsedModule { + hpm_module = L loc (HsModule { + hsmodName = Just (L loc mod_name), + hsmodExports = Nothing, + hsmodImports = [], + hsmodDecls = [], + hsmodDeprecMessage = Nothing, + hsmodHaddockModHeader = Nothing + }), + hpm_src_files = [], + hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] + }), + ms_hspp_file = "", -- none, it came inline + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + +summariseDecl :: PackageName + -> HscSource + -> Located ModuleName + -> Maybe (Located HsModule) + -> BkpM ModSummary +summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod +summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing + = do hsc_env <- getSession + let dflags = hsc_dflags hsc_env + -- TODO: this looks for modules in the wrong place + r <- liftIO $ summariseModule hsc_env + Map.empty -- GHC API recomp not supported + (hscSourceToIsBoot hsc_src) + lmodname + True -- Target lets you disallow, but not here + Nothing -- GHC API buffer support not supported + [] -- No exclusions + case r of + Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) + Just (Left err) -> throwErrors err + Just (Right summary) -> return summary + +-- | Up until now, GHC has assumed a single compilation target per source file. +-- Backpack files with inline modules break this model, since a single file +-- may generate multiple output files. How do we decide to name these files? +-- Should there only be one output file? This function our current heuristic, +-- which is we make a "fake" module and use that. +hsModuleToModSummary :: PackageName + -> HscSource + -> ModuleName + -> Located HsModule + -> BkpM ModSummary +hsModuleToModSummary pn hsc_src modname + hsmod = do + let imps = hsmodImports (unLoc hsmod) + loc = getLoc hsmod + hsc_env <- getSession + -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation + -- Use the PACKAGE NAME to find the location + let PackageName unit_fs = pn + dflags = hsc_dflags hsc_env + -- Unfortunately, we have to define a "fake" location in + -- order to appease the various code which uses the file + -- name to figure out where to put, e.g. object files. + -- To add insult to injury, we don't even actually use + -- these filenames to figure out where the hi files go. + -- A travesty! + location0 <- liftIO $ mkHomeModLocation2 dflags modname + (unpackFS unit_fs </> + moduleNameSlashes modname) + (case hsc_src of + HsigFile -> "hsig" + HsBootFile -> "hs-boot" + HsSrcFile -> "hs") + -- DANGEROUS: bootifying can POISON the module finder cache + let location = case hsc_src of + HsBootFile -> addBootSuffixLocnOut location0 + _ -> location0 + -- This duplicates a pile of logic in GHC.Driver.Make + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + + -- Also copied from 'getImports' + let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports modname loc + implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname + + let normal_imports = map convImport (implicit_imports ++ ordinary_imps) + required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports + + -- So that Finder can find it, even though it doesn't exist... + this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location + return ModSummary { + ms_mod = this_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = (case hiDir dflags of + Nothing -> "" + Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing, + ms_srcimps = map convImport src_idecls, + ms_textual_imps = normal_imports + -- We have to do something special here: + -- due to merging, requirements may end up with + -- extra imports + ++ extra_sig_imports + ++ required_by_imports, + -- This is our hack to get the parse tree to the right spot + ms_parsed_mod = Just (HsParsedModule { + hpm_module = hsmod, + hpm_src_files = [], -- TODO if we preprocessed it + hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] -- BOGUS + }), + ms_hs_date = time, + ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp + } + +-- | Create a new, externally provided hashed unit id from +-- a hash. +newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId +newInstalledUnitId (ComponentId cid_fs) (Just fs) + = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs) +newInstalledUnitId (ComponentId cid_fs) Nothing + = InstalledUnitId cid_fs diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs new file mode 100644 index 0000000000..709427ebd0 --- /dev/null +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -0,0 +1,83 @@ +-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' +-- mode. This syntax is used purely for testing purposes. + +module GHC.Driver.Backpack.Syntax ( + -- * Backpack abstract syntax + HsUnitId(..), + LHsUnitId, + HsModuleSubst, + LHsModuleSubst, + HsModuleId(..), + LHsModuleId, + HsComponentId(..), + LHsUnit, HsUnit(..), + LHsUnitDecl, HsUnitDecl(..), + IncludeDecl(..), + LRenaming, Renaming(..), + ) where + +import GhcPrelude + +import GHC.Driver.Phases +import GHC.Hs +import SrcLoc +import Outputable +import Module +import UnitInfo + +{- +************************************************************************ +* * + User syntax +* * +************************************************************************ +-} + +data HsComponentId = HsComponentId { + hsPackageName :: PackageName, + hsComponentId :: ComponentId + } + +instance Outputable HsComponentId where + ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn + +data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] +type LHsUnitId n = Located (HsUnitId n) + +type HsModuleSubst n = (Located ModuleName, LHsModuleId n) +type LHsModuleSubst n = Located (HsModuleSubst n) + +data HsModuleId n = HsModuleVar (Located ModuleName) + | HsModuleId (LHsUnitId n) (Located ModuleName) +type LHsModuleId n = Located (HsModuleId n) + +-- | Top level @unit@ declaration in a Backpack file. +data HsUnit n = HsUnit { + hsunitName :: Located n, + hsunitBody :: [LHsUnitDecl n] + } +type LHsUnit n = Located (HsUnit n) + +-- | A declaration in a package, e.g. a module or signature definition, +-- or an include. +data HsUnitDecl n + = DeclD HscSource (Located ModuleName) (Maybe (Located HsModule)) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ], + -- | Is this a @dependency signature@ include? If so, + -- we don't compile this include when we instantiate this + -- unit (as there should not be any modules brought into + -- scope.) + idSignatureInclude :: Bool + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: Located ModuleName + , renameTo :: Maybe (Located ModuleName) } +type LRenaming = Located Renaming diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs new file mode 100644 index 0000000000..9b71e3d3fb --- /dev/null +++ b/compiler/GHC/Driver/CmdLine.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.CmdLine + ( + processArgs, OptKind(..), GhcFlagMode(..), + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + errorsToGhcException, + + Err(..), Warn(..), WarnReason(..), + + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, + deprecate + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Util +import Outputable +import Panic +import Bag +import SrcLoc +import Json + +import Data.Function +import Data.List + +import Control.Monad (liftM, ap) + +-------------------------------------------------------- +-- The Flag and OptKind types +-------------------------------------------------------- + +data Flag m = Flag + { flagName :: String, -- Flag, without the leading "-" + flagOptKind :: OptKind m, -- What to do if we see it + flagGhcMode :: GhcFlagMode -- Which modes this flag affects + } + +defFlag :: String -> OptKind m -> Flag m +defFlag name optKind = Flag name optKind AllModes + +defGhcFlag :: String -> OptKind m -> Flag m +defGhcFlag name optKind = Flag name optKind OnlyGhc + +defGhciFlag :: String -> OptKind m -> Flag m +defGhciFlag name optKind = Flag name optKind OnlyGhci + +defHiddenFlag :: String -> OptKind m -> Flag m +defHiddenFlag name optKind = Flag name optKind HiddenFlag + +-- | GHC flag modes describing when a flag has an effect. +data GhcFlagMode + = OnlyGhc -- ^ The flag only affects the non-interactive GHC + | OnlyGhci -- ^ The flag only affects the interactive GHC + | AllModes -- ^ The flag affects multiple ghc modes + | HiddenFlag -- ^ This flag should not be seen in cli completion + +data OptKind m -- Suppose the flag is -f + = NoArg (EwM m ()) -- -f all by itself + | HasArg (String -> EwM m ()) -- -farg or -f arg + | SepArg (String -> EwM m ()) -- -f arg + | Prefix (String -> EwM m ()) -- -farg + | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn + | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn + + +-------------------------------------------------------- +-- The EwM monad +-------------------------------------------------------- + +-- | Used when filtering warnings: if a reason is given +-- it can be filtered out when displaying. +data WarnReason + = NoReason + | ReasonDeprecatedFlag + | ReasonUnrecognisedFlag + deriving (Eq, Show) + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json reason = JSString $ show reason + +-- | A command-line error message +newtype Err = Err { errMsg :: Located String } + +-- | A command-line warning message and the reason it arose +data Warn = Warn + { warnReason :: WarnReason, + warnMsg :: Located String + } + +type Errs = Bag Err +type Warns = Bag Warn + +-- EwM ("errors and warnings monad") is a monad +-- transformer for m that adds an (err, warn) state +newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg + -> Errs -> Warns + -> m (Errs, Warns, a) } + +instance Monad m => Functor (EwM m) where + fmap = liftM + +instance Monad m => Applicative (EwM m) where + pure v = EwM (\_ e w -> return (e, w, v)) + (<*>) = ap + +instance Monad m => Monad (EwM m) where + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') + +runEwM :: EwM m a -> m (Errs, Warns, a) +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag + +setArg :: Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + +addErr :: Monad m => String -> EwM m () +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) + +addWarn :: Monad m => String -> EwM m () +addWarn = addFlagWarn NoReason + +addFlagWarn :: Monad m => WarnReason -> String -> EwM m () +addFlagWarn reason msg = EwM $ + (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) + +deprecate :: Monad m => String -> EwM m () +deprecate s = do + arg <- getArg + addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) + +getArg :: Monad m => EwM m String +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) + +liftEwM :: Monad m => m a -> EwM m a +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) + + +-------------------------------------------------------- +-- A state monad for use in the command-line parser +-------------------------------------------------------- + +-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + deriving (Functor) + +instance Applicative (CmdLineP s) where + pure a = CmdLineP $ \s -> (a, s) + (<*>) = ap + +instance Monad (CmdLineP s) where + m >>= k = CmdLineP $ \s -> + let (a, s') = runCmdLine m s + in runCmdLine (k a) s' + + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState :: s -> CmdLineP s () +putCmdLineState s = CmdLineP $ \_ -> ((),s) + + +-------------------------------------------------------- +-- Processing arguments +-------------------------------------------------------- + +processArgs :: Monad m + => [Flag m] -- cmdline parser spec + -> [Located String] -- args + -> m ( [Located String], -- spare args + [Err], -- errors + [Warn] ) -- warnings +processArgs spec args = do + (errs, warns, spare) <- runEwM action + return (spare, bagToList errs, bagToList warns) + where + action = process args [] + + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (locArg@(L _ ('-' : arg)) : args) spare = + case findArg spec arg of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of + Left err -> + let b = process args spare + in (setArg locArg $ addErr err) >> b + + Right (action,rest) -> + let b = process rest spare + in (setArg locArg $ action) >> b + + Nothing -> process args (locArg : spare) + + process (arg : args) spare = process args (arg : spare) + + +processOneArg :: OptKind m -> String -> String -> [Located String] + -> Either String (EwM m (), [Located String]) +processOneArg opt_kind rest arg args + = let dash_arg = '-' : arg + rest_no_eq = dropEq rest + in case opt_kind of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #9776 + SepArg f -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #12625 + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> missingArgErr dash_arg + + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> Right (f dash_arg, args) + + OptIntSuffix f | null rest -> Right (f Nothing, args) + | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_arg, args) + +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg spec arg = + case sortBy (compare `on` (length . fst)) -- prefer longest matching flag + [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok :: OptKind t -> [Char] -> String -> Bool +arg_ok (NoArg _) rest _ = null rest +arg_ok (HasArg _) _ _ = True +arg_ok (SepArg _) rest _ = null rest +arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t + -- to improve error message (#12625) +arg_ok (OptIntSuffix _) _ _ = True +arg_ok (IntSuffix _) _ _ = True +arg_ok (FloatSuffix _) _ _ = True +arg_ok (OptPrefix _) _ _ = True +arg_ok (PassFlag _) rest _ = null rest +arg_ok (AnySuffix _) _ _ = True + +-- | Parse an Int +-- +-- Looks for "433" or "=342", with no trailing gubbins +-- * n or =n => Just n +-- * gibberish => Nothing +parseInt :: String -> Maybe Int +parseInt s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +-- | Discards a leading equals sign +dropEq :: String -> String +dropEq ('=' : s) = s +dropEq s = s + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-------------------------------------------------------- +-- Utils +-------------------------------------------------------- + + +-- See Note [Handling errors when parsing flags] +errorsToGhcException :: [(String, -- Location + String)] -- Error + -> GhcException +errorsToGhcException errs = + UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] + +{- Note [Handling errors when parsing commandline flags] + +Parsing of static and mode flags happens before any session is started, i.e., +before the first call to 'GHC.withGhc'. Therefore, to report errors for +invalid usage of these two types of flags, we can not call any function that +needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags +is not set either). So we always print "on the commandline" as the location, +which is true except for Api users, which is probably ok. + +When reporting errors for invalid usage of dynamic flags we /can/ make use of +DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. + +Before, we called unsafeGlobalDynFlags when an invalid (combination of) +flag(s) was given on the commandline, resulting in panics (#9963). +-} diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs new file mode 100644 index 0000000000..e52d3216d5 --- /dev/null +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -0,0 +1,264 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section{Code output phase} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Driver.CodeOutput ( codeOutput, outputForeignStubs ) where + +#include "HsVersions.h" + +import GhcPrelude + +import AsmCodeGen ( nativeCodeGen ) +import GHC.CmmToLlvm ( llvmCodeGen ) + +import UniqSupply ( mkSplitUniqSupply ) + +import GHC.Driver.Finder ( mkStubPaths ) +import GHC.CmmToC ( writeC ) +import GHC.Cmm.Lint ( cmmLint ) +import GHC.Driver.Packages +import GHC.Cmm ( RawCmmGroup ) +import GHC.Driver.Types +import GHC.Driver.Session +import Stream ( Stream ) +import qualified Stream +import FileCleanup + +import ErrUtils +import Outputable +import Module +import SrcLoc + +import Control.Exception +import System.Directory +import System.FilePath +import System.IO + +{- +************************************************************************ +* * +\subsection{Steering} +* * +************************************************************************ +-} + +codeOutput :: DynFlags + -> Module + -> FilePath + -> ModLocation + -> ForeignStubs + -> [(ForeignSrcLang, FilePath)] + -- ^ additional files to be compiled with with the C compiler + -> [InstalledUnitId] + -> Stream IO RawCmmGroup a -- Compiled C-- + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), + [(ForeignSrcLang, FilePath)]{-foreign_fps-}, + a) + +codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps + cmm_stream + = + do { + -- Lint each CmmGroup as it goes past + ; let linted_cmm_stream = + if gopt Opt_DoCmmLinting dflags + then Stream.mapM do_lint cmm_stream + else cmm_stream + + do_lint cmm = withTimingSilent + dflags + (text "CmmLint"<+>brackets (ppr this_mod)) + (const ()) $ do + { case cmmLint dflags cmm of + Just err -> do { log_action dflags + dflags + NoReason + SevDump + noSrcSpan + (defaultDumpStyle dflags) + err + ; ghcExit dflags 1 + } + Nothing -> return () + ; return cmm + } + + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; a <- case hscTarget dflags of + HscAsm -> outputAsm dflags this_mod location filenm + linted_cmm_stream + HscC -> outputC dflags filenm linted_cmm_stream pkg_deps + HscLlvm -> outputLlvm dflags filenm linted_cmm_stream + HscInterpreted -> panic "codeOutput: HscInterpreted" + HscNothing -> panic "codeOutput: HscNothing" + ; return (filenm, stubs_exist, foreign_fps, a) + } + +doOutput :: String -> (Handle -> IO a) -> IO a +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action + +{- +************************************************************************ +* * +\subsection{C} +* * +************************************************************************ +-} + +outputC :: DynFlags + -> FilePath + -> Stream IO RawCmmGroup a + -> [InstalledUnitId] + -> IO a + +outputC dflags filenm cmm_stream packages + = do + withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + + -- figure out which header files to #include in the generated .hc file: + -- + -- * extra_includes from packages + -- * -#include options from the cmdline and OPTIONS pragmas + -- * the _stub.h file, if there is one. + -- + let rts = getPackageDetails dflags rtsUnitId + + let cc_injects = unlines (map mk_include (includes rts)) + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" + + let pkg_names = map installedUnitIdString packages + + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h cc_injects + Stream.consume cmm_stream (writeC dflags h) + +{- +************************************************************************ +* * +\subsection{Assembler} +* * +************************************************************************ +-} + +outputAsm :: DynFlags -> Module -> ModLocation -> FilePath + -> Stream IO RawCmmGroup a + -> IO a +outputAsm dflags this_mod location filenm cmm_stream + | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags + = do ncg_uniqs <- mkSplitUniqSupply 'n' + + debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + + {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream + + | otherwise + = panic "This compiler was built without a native code generator" + +{- +************************************************************************ +* * +\subsection{LLVM} +* * +************************************************************************ +-} + +outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm dflags filenm cmm_stream + = do {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen dflags f cmm_stream + +{- +************************************************************************ +* * +\subsection{Foreign import/export} +* * +************************************************************************ +-} + +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs + -> IO (Bool, -- Header file created + Maybe FilePath) -- C file created +outputForeignStubs dflags mod location stubs + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags TFL_CurrentModule "c" + + case stubs of + NoStubs -> + return (False, Nothing) + + ForeignStubs h_code c_code -> do + let + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc dflags stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode CStyle h_code + stub_h_output_w = showSDoc dflags stub_h_output_d + + createDirectoryIfMissing True (takeDirectory stub_h) + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export header file" + FormatC + stub_h_output_d + + -- we need the #includes from the rts package for the stub files + let rts_includes = + let rts_pkg = getPackageDetails dflags rtsUnitId in + concatMap mk_include (includes rts_pkg) + mk_include i = "#include \"" ++ i ++ "\"\n" + + -- wrapper code mentions the ffi_arg type, which comes from ffi.h + ffi_includes + | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n" + | otherwise = "" + + stub_h_file_exists + <- outputForeignStubs_help stub_h stub_h_output_w + ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export stubs" FormatC stub_c_output_d + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include <Rts.h>\n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. + + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where + cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n" + cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" + + +-- Don't use doOutput for dumping the f. export stubs +-- since it is more than likely that the stubs file will +-- turn out to be empty, in which case no file should be created. +outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool +outputForeignStubs_help _fname "" _header _footer = return False +outputForeignStubs_help fname doc_str header footer + = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") + return True diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs new file mode 100644 index 0000000000..c7c9c1af1f --- /dev/null +++ b/compiler/GHC/Driver/Finder.hs @@ -0,0 +1,844 @@ +{- +(c) The University of Glasgow, 2000-2006 + +\section[Finder]{Module Finder} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Driver.Finder ( + flushFinderCaches, + FindResult(..), + findImportedModule, + findPluginModule, + findExactModule, + findHomeModule, + findExposedPackageModule, + mkHomeModLocation, + mkHomeModLocation2, + mkHiOnlyModLocation, + mkHiPath, + mkObjPath, + addHomeModuleToFinder, + uncacheModule, + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + cannotFindModule, + cannotFindInterface, + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Module +import GHC.Driver.Types +import GHC.Driver.Packages +import FastString +import Util +import PrelNames ( gHC_PRIM ) +import GHC.Driver.Session +import Outputable +import Maybes ( expectJust ) + +import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) +import System.Directory +import System.FilePath +import Control.Monad +import Data.Time + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllPackages for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +-- remove all the home modules from the cache; package modules are +-- assumed to not move around during a session. +flushFinderCaches :: HscEnv -> IO () +flushFinderCaches hsc_env = + atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + where + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True + | otherwise = False + +addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () +addToFinderCache ref key val = + atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) + +removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () +removeFromFinderCache ref key = + atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) + +lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) +lookupFinderCache ref key = do + c <- readIORef ref + return $! lookupInstalledModuleEnv c key + +-- ----------------------------------------------------------------------------- +-- The three external entry points + +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult +findImportedModule hsc_env mod_name mb_pkg = + case mb_pkg of + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import + where + home_import = findHomeModule hsc_env mod_name + + pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg + + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing + +-- | Locate a plugin module requested by the user, for a compiler +-- plugin. This consults the same set of exposed packages as +-- 'findImportedModule', unless @-hide-all-plugin-packages@ or +-- @-plugin-package@ are specified. +findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule hsc_env mod_name = + findHomeModule hsc_env mod_name + `orIfNotFound` + findExposedPluginPackageModule hsc_env mod_name + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). + +findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult +findExactModule hsc_env mod = + let dflags = hsc_dflags hsc_env + in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags + then findInstalledHomeModule hsc_env (installedModuleName mod) + else findPackageModule hsc_env mod + +-- ----------------------------------------------------------------------------- +-- Helpers + +-- | Given a monadic actions @this@ and @or_this@, first execute +-- @this@. If the returned 'FindResult' is successful, return +-- it; otherwise, execute @or_this@. If both failed, this function +-- also combines their failure messages in a reasonable way. +orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult +orIfNotFound this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + _other -> return res + +-- | Helper function for 'findHomeModule': this function wraps an IO action +-- which would look up @mod_name@ in the file system (the home package), +-- and first consults the 'hsc_FC' cache to see if the lookup has already +-- been done. Otherwise, do the lookup (with the IO action) and save +-- the result in the finder cache and the module location cache (if it +-- was successful.) +homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult +homeSearchCache hsc_env mod_name do_this = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + modLocationCache hsc_env mod do_this + +findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString + -> IO FindResult +findExposedPackageModule hsc_env mod_name mb_pkg + = findLookupResult hsc_env + $ lookupModuleWithSuggestions + (hsc_dflags hsc_env) mod_name mb_pkg + +findExposedPluginPackageModule :: HscEnv -> ModuleName + -> IO FindResult +findExposedPluginPackageModule hsc_env mod_name + = findLookupResult hsc_env + $ lookupPluginModuleWithSuggestions + (hsc_dflags hsc_env) mod_name Nothing + +findLookupResult :: HscEnv -> LookupResult -> IO FindResult +findLookupResult hsc_env r = case r of + LookupFound m pkg_conf -> do + let im = fst (splitModuleInsts m) + r' <- findPackageModule_ hsc_env im pkg_conf + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc _ -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = []}) + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens + , fr_unusables = [] + , fr_suggestions = [] }) + LookupUnusable unusable -> + let unusables' = map get_unusable unusable + get_unusable (m, ModUnusable r) = (moduleUnitId m, r) + get_unusable (_, r) = + pprPanic "findLookupResult: unexpected origin" (ppr r) + in return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = unusables' + , fr_suggestions = [] }) + LookupNotFound suggest -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = [] + , fr_suggestions = suggest }) + +modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult +modLocationCache hsc_env mod do_this = do + m <- lookupFinderCache (hsc_FC hsc_env) mod + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod result + return result + +mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule +mkHomeInstalledModule dflags mod_name = + let iuid = thisInstalledUnitId dflags + in InstalledModule iuid mod_name + +-- This returns a module because it's more convenient for users +addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module +addHomeModuleToFinder hsc_env mod_name loc = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) + return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) + +uncacheModule :: HscEnv -> ModuleName -> IO () +uncacheModule hsc_env mod_name = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + removeFromFinderCache (hsc_FC hsc_env) mod + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = do + r <- findInstalledHomeModule hsc_env mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + where + dflags = hsc_dflags hsc_env + uid = thisPackage dflags + +-- | Implements the search for a module name in the home package only. Calling +-- this function directly is usually *not* what you want; currently, it's used +-- as a building block for the following operations: +-- +-- 1. When you do a normal package lookup, we first check if the module +-- is available in the home module, before looking it up in the package +-- database. +-- +-- 2. When you have a package qualified import with package name "this", +-- we shortcut to the home module. +-- +-- 3. When we look up an exact 'Module', if the unit id associated with +-- the module is the current home module do a look up in the home module. +-- +-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to +-- call this.) +findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule hsc_env mod_name = + homeSearchCache hsc_env mod_name $ + let + dflags = hsc_dflags hsc_env + home_path = importPaths dflags + hisuf = hiSuf dflags + mod = mkHomeInstalledModule dflags mod_name + + source_exts = + [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") + , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") + , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") + , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") + ] + + -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that + -- when hiDir field is set in dflags, we know to look there (see #16500) + hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name) + , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts + in + + -- special case for GHC.Prim; we won't find it in the filesystem. + -- This is important only when compiling the base package (where GHC.Prim + -- is a home module). + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else searchPathExts home_path mod exts + + +-- | Search for a module in external packages only. +findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult +findPackageModule hsc_env mod = do + let + dflags = hsc_dflags hsc_env + pkg_id = installedModuleUnitId mod + -- + case lookupInstalledPackage dflags pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) + Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by @Packages.hs@) and (2) +-- the 'UnitInfo' must be consistent with the unit id in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. +findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult +findPackageModule_ hsc_env mod pkg_conf = + ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) ) + modLocationCache hsc_env mod $ + + -- special case for GHC.Prim; we won't find it in the filesystem. + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else + + let + dflags = hsc_dflags hsc_env + tag = buildTag dflags + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf + + import_dirs = importDirs pkg_conf + -- we never look for a .hi-boot file in an external package; + -- .hi-boot files only make sense for the home package. + in + case import_dirs of + [one] | MkDepend <- ghcMode dflags -> do + -- there's only one place that this .hi file can be, so + -- don't bother looking for it. + let basename = moduleNameSlashes (installedModuleName mod) + loc <- mk_hi_loc one basename + return (InstalledFound loc mod) + _otherwise -> + searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts + :: [FilePath] -- paths to search + -> InstalledModule -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action + ) + ] + -> IO InstalledFindResult + +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result + + where + basename = moduleNameSlashes (installedModuleName mod) + + to_search :: [(FilePath, IO ModLocation)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path </> basename + file = base <.> ext + ] + + search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) + + search ((file, mk_result) : rest) = do + b <- doesFileExist file + if b + then do { loc <- mk_result; return (InstalledFound loc mod) } + else search rest + +mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt + -> FilePath -> BaseName -> IO ModLocation +mkHomeModLocationSearched dflags mod suff path basename = do + mkHomeModLocation2 dflags mod (path </> basename) suff + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): (moduleNameSlashes mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do + let (basename,extension) = splitExtension src_filename + mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: DynFlags + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation +mkHomeModLocation2 dflags mod src_basename ext = do + let mod_basename = moduleNameSlashes mod + + obj_fn = mkObjPath dflags src_basename mod_basename + hi_fn = mkHiPath dflags src_basename mod_basename + hie_fn = mkHiePath dflags src_basename mod_basename + + return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn, + ml_hie_file = hie_fn }) + +mkHomeModHiOnlyLocation :: DynFlags + -> ModuleName + -> FilePath + -> BaseName + -> IO ModLocation +mkHomeModHiOnlyLocation dflags mod path basename = do + loc <- mkHomeModLocation2 dflags mod (path </> basename) "" + return loc { ml_hs_file = Nothing } + +mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String + -> IO ModLocation +mkHiOnlyModLocation dflags hisuf path basename + = do let full_basename = path </> basename + obj_fn = mkObjPath dflags full_basename basename + hie_fn = mkHiePath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn, + ml_hie_file = hie_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkObjPath dflags basename mod_basename = obj_basename <.> osuf + where + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir </> mod_basename + | otherwise = basename + + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiPath dflags basename mod_basename = hi_basename <.> hisuf + where + hidir = hiDir dflags + hisuf = hiSuf dflags + + hi_basename | Just dir <- hidir = dir </> mod_basename + | otherwise = basename + +-- | Constructs the filename of a .hie file for a given source file. +-- Does /not/ check whether the .hie file exists +mkHiePath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf + where + hiedir = hieDir dflags + hiesuf = hieSuf dflags + + hie_basename | Just dir <- hiedir = dir </> mod_basename + | otherwise = basename + + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> ModuleName + -> ModLocation + -> FilePath + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = moduleNameSlashes mod + src_basename = dropExtension $ expectJust "mkStubPaths" + (ml_hs_file location) + + stub_basename0 + | Just dir <- stubdir = dir </> mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + stub_basename <.> "h" + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) + +-- ----------------------------------------------------------------------------- +-- Error messages + +cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc +cannotFindModule flags mod res = + cantFindErr (sLit cannotFindMsg) + (sLit "Ambiguous module name") + flags mod res + where + cannotFindMsg = + case res of + NotFound { fr_mods_hidden = hidden_mods + , fr_pkgs_hidden = hidden_pkgs + , fr_unusables = unusables } + | not (null hidden_mods && null hidden_pkgs && null unusables) + -> "Could not load module" + _ -> "Could not find module" + +cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc +cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") + (sLit "Ambiguous interface for") + +cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult + -> SDoc +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + sep [text "it was found in multiple packages:", + hsep (map ppr pkgs) ] + ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnitId m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = text "it is bound as" <+> ppr m <+> + text "by" <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [text "package" <+> ppr (moduleUnitId m)] + else [] ++ + map ((text "a reexport in package" <+>) + .ppr.packageConfigId) res ++ + if f then [text "a package flag"] else [] + ) + +cantFindErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + NoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" + + NotFound { fr_paths = files, fr_pkg = mb_pkg + , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens + , fr_unusables = unusables, fr_suggestions = suggest } + | Just pkg <- mb_pkg, pkg /= thisPackage dflags + -> not_found_in_package pkg files + + | not (null suggest) + -> pp_suggestions suggest $$ tried_these files dflags + + | null files && null mod_hiddens && + null pkg_hiddens && null unusables + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + vcat (map unusable unusables) $$ + tried_these files dflags + + _ -> panic "cantFindErr" + + build_tag = buildTag dflags + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files dflags + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files dflags + + pkg_hidden :: UnitId -> SDoc + pkg_hidden uid = + text "It is a member of the hidden package" + <+> quotes (ppr uid) + --FIXME: we don't really want to show the unit id here we should + -- show the source package id or installed package id if it's ambiguous + <> dot $$ pkg_hidden_hint uid + pkg_hidden_hint uid + | gopt Opt_BuildingCabalPackage dflags + = let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid) + in text "Perhaps you need to add" <+> + quotes (ppr (packageName pkg)) <+> + text "to the build-depends in your .cabal file." + | Just pkg <- lookupUnit dflags uid + = text "You can run" <+> + quotes (text ":set -package " <> ppr (packageName pkg)) <+> + text "to expose it." $$ + text "(Note: this unloads all the modules in the current scope.)" + | otherwise = Outputable.empty + + mod_hidden pkg = + text "it is a hidden module in the package" <+> quotes (ppr pkg) + + unusable (pkg, reason) + = text "It is a member of the package" + <+> quotes (ppr pkg) + $$ pprReason (text "which is") reason + + pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = Outputable.empty + | otherwise = hang (text "Perhaps you meant") + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty + provenance (ModOrigin{ fromOrigPackage = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (text "from" <+> ppr (moduleUnitId mod)) + | f && moduleName mod == m + = parens (text "from" <+> ppr (moduleUnitId mod)) + | (pkg:_) <- res + = parens (text "from" <+> ppr (packageConfigId pkg) + <> comma <+> text "reexporting" <+> ppr mod) + | f + = parens (text "defined via package flags to be" + <+> ppr mod) + | otherwise = Outputable.empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty + provenance (ModOrigin{ fromOrigPackage = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (text "needs flag -package-key" + <+> ppr (moduleUnitId mod)) + | (pkg:_) <- rhs + = parens (text "needs flag -package-id" + <+> ppr (packageConfigId pkg)) + | otherwise = Outputable.empty + +cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName + -> InstalledFindResult -> SDoc +cantFindInstalledErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + InstalledNoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) + -> not_found_in_package pkg files + + | null files + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> tried_these files dflags + + _ -> panic "cantFindInstalledErr" + + build_tag = buildTag dflags + + looks_like_srcpkgid :: InstalledUnitId -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a unit id FastString into a source package ID + -- FastString and see if it means anything. + | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files dflags + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files dflags + +tried_these :: [FilePath] -> DynFlags -> SDoc +tried_these files dflags + | null files = Outputable.empty + | verbosity dflags < 3 = + text "Use -v (or `:set -v` in ghci) " <> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs new file mode 100644 index 0000000000..027d8831b7 --- /dev/null +++ b/compiler/GHC/Driver/Hooks.hs @@ -0,0 +1,121 @@ +-- \section[Hooks]{Low level API hooks} + +-- NB: this module is SOURCE-imported by DynFlags, and should primarily +-- refer to *types*, rather than *code* + +{-# LANGUAGE CPP, RankNTypes #-} + +module GHC.Driver.Hooks + ( Hooks + , emptyHooks + , lookupHook + , getHooked + -- the hooks: + , dsForeignsHook + , tcForeignImportsHook + , tcForeignExportsHook + , hscFrontendHook + , hscCompileCoreExprHook + , ghcPrimIfaceHook + , runPhaseHook + , runMetaHook + , linkHook + , runRnSpliceHook + , getValueSafelyHook + , createIservProcessHook + , stgToCmmHook + , cmmToRawCmmHook + ) +where + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Types +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import OrdList +import TcRnTypes +import Bag +import RdrName +import Name +import Id +import CoreSyn +import GHCi.RemoteTypes +import SrcLoc +import Type +import System.Process +import BasicTypes +import Module +import TyCon +import CostCentre +import GHC.Stg.Syntax +import Stream +import GHC.Cmm +import GHC.Hs.Extension + +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Hooks} +* * +************************************************************************ +-} + +-- | Hooks can be used by GHC API clients to replace parts of +-- the compiler pipeline. If a hook is not installed, GHC +-- uses the default built-in behaviour + +emptyHooks :: Hooks +emptyHooks = Hooks + { dsForeignsHook = Nothing + , tcForeignImportsHook = Nothing + , tcForeignExportsHook = Nothing + , hscFrontendHook = Nothing + , hscCompileCoreExprHook = Nothing + , ghcPrimIfaceHook = Nothing + , runPhaseHook = Nothing + , runMetaHook = Nothing + , linkHook = Nothing + , runRnSpliceHook = Nothing + , getValueSafelyHook = Nothing + , createIservProcessHook = Nothing + , stgToCmmHook = Nothing + , cmmToRawCmmHook = Nothing + } + +data Hooks = Hooks + { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) + , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) + , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)) + , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) + , hscCompileCoreExprHook :: + Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) + , ghcPrimIfaceHook :: Maybe ModIface + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath)) + , runMetaHook :: Maybe (MetaHook TcM) + , linkHook :: Maybe (GhcLink -> DynFlags -> Bool + -> HomePackageTable -> IO SuccessFlag) + , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) + , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type + -> IO (Maybe HValue)) + , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) + , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs + -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ()) + , cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a + -> IO (Stream IO RawCmmGroup a)) + } + +getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a +getHooked hook def = fmap (lookupHook hook def) getDynFlags + +lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a +lookupHook hook def = fromMaybe def . hook . hooks diff --git a/compiler/GHC/Driver/Hooks.hs-boot b/compiler/GHC/Driver/Hooks.hs-boot new file mode 100644 index 0000000000..40ee5560ee --- /dev/null +++ b/compiler/GHC/Driver/Hooks.hs-boot @@ -0,0 +1,7 @@ +module GHC.Driver.Hooks where + +import GhcPrelude () + +data Hooks + +emptyHooks :: Hooks diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs new file mode 100644 index 0000000000..e5c030f741 --- /dev/null +++ b/compiler/GHC/Driver/Main.hs @@ -0,0 +1,1952 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fprof-auto-top #-} + +------------------------------------------------------------------------------- +-- +-- | Main API for compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in GHC.Driver.Pipeline +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.Main + ( + -- * Making an HscEnv + newHscEnv + + -- * Compiling complete source files + , Messager, batchMsg + , HscStatus (..) + , hscIncrementalCompile + , hscMaybeWriteIface + , hscCompileCmmFile + + , hscGenHardCode + , hscInteractive + + -- * Running passes separately + , hscParse + , hscTypecheckRename + , hscDesugar + , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscIsGHCiMonad + , hscGetModuleInterface + , hscRnImportDecls + , hscTcRnLookupRdrName + , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt + , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls + , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType + , hscParseExpr + , hscParseType + , hscCompileCoreExpr + -- * Low-level exports for hooks + , hscCompileCoreExpr' + -- We want to make sure that we export enough to be able to redefine + -- hsc_typecheck in client code + , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen + , getHscEnv + , hscSimpleIface' + , oneShotMsg + , dumpIfaceStats + , ioMsgMaybe + , showModuleIndex + , hscAddSptEntries + ) where + +import GhcPrelude + +import Data.Data hiding (Fixity, TyCon) +import Data.Maybe ( fromJust ) +import Id +import GHC.Runtime.Interpreter ( addSptEntry ) +import GHCi.RemoteTypes ( ForeignHValue ) +import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) +import GHC.Runtime.Linker +import CoreTidy ( tidyExpr ) +import Type ( Type ) +import {- Kind parts of -} Type ( Kind ) +import CoreLint ( lintInteractiveExpr ) +import VarEnv ( emptyTidyEnv ) +import Panic +import ConLike +import Control.Concurrent + +import ApiAnnotation +import Module +import GHC.Driver.Packages +import RdrName +import GHC.Hs +import GHC.Hs.Dump +import CoreSyn +import StringBuffer +import Parser +import Lexer +import SrcLoc +import TcRnDriver +import GHC.IfaceToCore ( typecheckIface ) +import TcRnMonad +import TcHsSyn ( ZonkFlexi (DefaultFlexi) ) +import NameCache ( initNameCache ) +import GHC.Iface.Load ( ifaceStats, initExternalPackageState ) +import PrelInfo +import GHC.Iface.Utils +import GHC.HsToCore +import SimplCore +import GHC.Iface.Tidy +import GHC.CoreToStg.Prep +import GHC.CoreToStg ( coreToStg ) +import GHC.Stg.Syntax +import GHC.Stg.FVs ( annTopBindingsFreeVars ) +import GHC.Stg.Pipeline ( stg2stg ) +import qualified GHC.StgToCmm as StgToCmm ( codeGen ) +import CostCentre +import ProfInit +import TyCon +import Name +import NameSet +import GHC.Cmm +import GHC.Cmm.Parser ( parseCmmFile ) +import GHC.Cmm.Info.Build +import GHC.Cmm.Pipeline +import GHC.Cmm.Info +import GHC.Driver.CodeOutput +import InstEnv +import FamInstEnv +import Fingerprint ( Fingerprint ) +import GHC.Driver.Hooks +import TcEnv +import PrelNames +import GHC.Driver.Plugins +import GHC.Runtime.Loader ( initializePlugins ) + +import GHC.Driver.Session +import ErrUtils + +import Outputable +import NameEnv +import HscStats ( ppSourceStats ) +import GHC.Driver.Types +import FastString +import UniqSupply +import Bag +import Exception +import qualified Stream +import Stream (Stream) + +import Util + +import Data.List ( nub, isPrefixOf, partition ) +import Control.Monad +import Data.IORef +import System.FilePath as FilePath +import System.Directory +import System.IO (fixIO) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Set (Set) +import Data.Functor +import Control.DeepSeq (force) + +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) + +#include "HsVersions.h" + + +{- ********************************************************************** +%* * + Initialisation +%* * +%********************************************************************* -} + +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do + eps_var <- newIORef initExternalPackageState + us <- mkSplitUniqSupply 'r' + nc_var <- newIORef (initNameCache us knownKeyNames) + fc_var <- newIORef emptyInstalledModuleEnv + iserv_mvar <- newMVar Nothing + emptyDynLinker <- uninitializedLinker + return HscEnv { hsc_dflags = dflags + , hsc_targets = [] + , hsc_mod_graph = emptyMG + , hsc_IC = emptyInteractiveContext dflags + , hsc_HPT = emptyHomePackageTable + , hsc_EPS = eps_var + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_var = Nothing + , hsc_iserv = iserv_mvar + , hsc_dynLinker = emptyDynLinker + } + +-- ----------------------------------------------------------------------------- + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not $ isEmptyBag errs) $ throwErrors errs + +-- | Log warnings and throw errors, assuming the messages +-- contain at least one error (e.g. coming from PFailed) +handleWarningsThrowErrors :: Messages -> Hsc a +handleWarningsThrowErrors (warns, errs) = do + logWarnings warns + dflags <- getDynFlags + (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings + liftIO $ printBagOfErrors dflags wWarns + throwErrors (unionBags errs wErrs) + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + ((warns,errs), mb_r) <- liftIO ioA + logWarnings warns + case mb_r of + Nothing -> throwErrors errs + Just r -> ASSERT( isEmptyBag errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + ((warns,_errs), mb_r) <- liftIO $ ioA + logWarnings warns + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] +hscTcRnLookupRdrName hsc_env0 rdr_name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name + -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } + +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name + +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations +hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls + +-- ----------------------------------------------------------------------------- +-- | parse a file, returning the abstract syntax + +hscParse :: HscEnv -> ModSummary -> IO HsParsedModule +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc HsParsedModule +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = {-# SCC "Parser" #-} + withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do + dflags <- getDynFlags + let src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + + -------------------------- Parser ---------------- + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + let parseMod | HsigFile == ms_hsc_src mod_summary + = parseSignature + | otherwise = parseModule + + case unP parseMod (mkPState dflags buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getMessages pst dflags) + POk pst rdr_module -> do + let (warns, errs) = getMessages pst dflags + logWarnings warns + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + FormatText (ppSourceStats False rdr_module) + when (not $ isEmptyBag errs) $ throwErrors errs + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "<built-in>" and "<command-line>" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = FilePath.normalise src_filename + srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) + $ filter (not . (== n_hspp)) + $ map FilePath.normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location mod_summary) of + Just f -> filter (/= FilePath.normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let api_anns = ApiAnns { + apiAnnItems = M.fromListWith (++) $ annotations pst, + apiAnnEofPos = eof_pos pst, + apiAnnComments = M.fromList (annotations_comments pst), + apiAnnRogueComments = comment_q pst + } + res = HsParsedModule { + hpm_module = rdr_module, + hpm_src_files = srcs2, + hpm_annotations = api_anns + } + + -- apply parse transformation of plugins + let applyPluginAction p opts + = parsedResultAction p opts mod_summary + withPlugins dflags applyPluginAction res + + +-- ----------------------------------------------------------------------------- +-- | If the renamed source has been kept, extract it. Dump it if requested. +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- Hsc $ \e w -> return (e, w) + liftIO $ do + -- Validate Scopes + let mdl = hie_module hieFile + case validateScopes mdl $ getAsts $ hie_asts hieFile of + [] -> putMsg dflags $ text "Got valid scopes" + xs -> do + putMsg dflags $ text "Got invalid scopes" + mapM_ (putMsg dflags) xs + -- Roundtrip testing + nc <- readIORef $ hsc_NC hs_env + (file', _) <- readHieFile nc out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg dflags $ text "Got no roundtrip errors" + xs -> do + putMsg dflags $ text "Got roundtrip errors" + mapM_ (putMsg dflags) xs + return rn_info + + +-- ----------------------------------------------------------------------------- +-- | Rename and typecheck a module, additionally returning the renamed syntax +hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule + -> IO (TcGblEnv, RenamedStuff) +hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ + hsc_typecheck True mod_summary (Just rdr_module) + + +-- | A bunch of logic piled around around @tcRnModule'@, concerning a) backpack +-- b) concerning dumping rename info and hie files. It would be nice to further +-- separate this stuff out, probably in conjunction better separating renaming +-- and type checking (#17781). +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkModule (thisPackage dflags) mod_name + inner_mod = canonicalizeHomeModule dflags mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + ioMsgMaybe $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + -- TODO are we extracting anything when we merely instantiate a signature? + -- If not, try to move this into the "else" case above. + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' sum save_rn_syntax mod = do + hsc_env <- getHscEnv + dflags <- getDynFlags + + -- -Wmissing-safe-haskell-mode + when (not (safeHaskellModeEnabled dflags) + && wopt Opt_WarnMissingSafeHaskellMode dflags) $ + logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ + mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ + warnMissingSafeHaskellMode + + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env sum + save_rn_syntax mod + + -- See Note [Safe Haskell Overlapping Instances Implementation] + -- although this is used for more than just that failure case. + (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res) + let allSafeOK = safeInferred dflags && tcSafeOK + + -- end of the safe haskell line, how to respond to user? + res <- if not (safeHaskellOn dflags) + || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res whyUnsafe + + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnSafe) $ + mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ + errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ + mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ + errTwthySafe tcg_res') + False -> return () + return tcg_res' + + -- apply plugins to the type checking result + + + return res + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + errTwthySafe t = quotes (pprMod t) + <+> text "is marked as Trustworthy but has been inferred as safe!" + warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum)) + <+> text "is missing Safe Haskell mode" + +-- | Convert a typechecked module to Core +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result = + runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result + +hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_location tc_result = do + hsc_env <- getHscEnv + r <- ioMsgMaybe $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result + + -- always check -Werror after desugaring, this is the last opportunity for + -- warnings to arise before the backend. + handleWarnings + return r + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result + + +{- ********************************************************************** +%* * + The main compiler pipeline +%* * +%********************************************************************* -} + +{- + -------------------------------- + The compilation proper + -------------------------------- + +It's the task of the compilation proper to compile Haskell, hs-boot and core +files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all +(the module is still parsed and type-checked. This feature is mostly used by +IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', +'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' +mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. + +The modes are kept separate because of their different types and meanings: + + * In 'one-shot' mode, we're only compiling a single file and can therefore + discard the new ModIface and ModDetails. This is also the reason it only + targets hard-code; compiling to byte-code or nothing doesn't make sense when + we discard the result. + + * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface + and ModDetails. 'Batch' mode doesn't target byte-code since that require us to + return the newly compiled byte-code. + + * 'Nothing' mode has exactly the same type as 'batch' mode but they're still + kept separate. This is because compiling to nothing is fairly special: We + don't output any interface files, we don't run the simplifier and we don't + generate any code. + + * 'Interactive' mode is similar to 'batch' mode except that we return the + compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time error. +This is the only thing that isn't caught by the type-system. +-} + + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () + +-- | This function runs GHC's frontend with recompilation +-- avoidance. Specifically, it checks if recompilation is needed, +-- and if it is, it parses and typechecks the input module. +-- It does not write out the results of typechecking (See +-- compileOne and hscIncrementalCompile). +hscIncrementalFrontend :: Bool -- always do basic recompilation check? + -> Maybe TcGblEnv + -> Maybe Messager + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface, if available + -> (Int,Int) -- (i,n) = module i of n (for msgs) + -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) + +hscIncrementalFrontend + always_do_basic_recompilation_check m_tc_result + mHscMessage mod_summary source_modified mb_old_iface mod_index + = do + hsc_env <- getHscEnv + + let msg what = case mHscMessage of + Just hscMessage -> hscMessage hsc_env mod_index what mod_summary + Nothing -> return () + + skip iface = do + liftIO $ msg UpToDate + return $ Left iface + + compile mb_old_hash reason = do + liftIO $ msg reason + (tc_result, _) <- hsc_typecheck False mod_summary Nothing + return $ Right (FrontendTypecheck tc_result, mb_old_hash) + + stable = case source_modified of + SourceUnmodifiedAndStable -> True + _ -> False + + case m_tc_result of + Just tc_result + | not always_do_basic_recompilation_check -> + return $ Right (FrontendTypecheck tc_result, Nothing) + _ -> do + (recomp_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary + source_modified mb_old_iface + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface + + case mb_checked_iface of + Just iface | not (recompileRequired recomp_reqd) -> + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (#481) and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. + case m_tc_result of + Nothing + | mi_used_th iface && not stable -> + compile mb_old_hash (RecompBecause "TH") + _ -> + skip iface + _ -> + case m_tc_result of + Nothing -> compile mb_old_hash recomp_reqd + Just tc_result -> + return $ Right (FrontendTypecheck tc_result, mb_old_hash) + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts +-- of the pipeline. +-- We return a interface if we already had an old one around and recompilation +-- was not needed. Otherwise it will be created during later passes when we +-- run the compilation pipeline. +hscIncrementalCompile :: Bool + -> Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> (Int,Int) + -> IO (HscStatus, DynFlags) +hscIncrementalCompile always_do_basic_recompilation_check m_tc_result + mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index + = do + dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env') + let hsc_env'' = hsc_env' { hsc_dflags = dflags } + + -- One-shot mode needs a knot-tying mutable variable for interface + -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. + -- See also Note [hsc_type_env_var hack] + type_env_var <- newIORef emptyNameEnv + let mod = ms_mod mod_summary + hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'')) + = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) } + | otherwise + = hsc_env'' + + -- NB: enter Hsc monad here so that we don't bail out early with + -- -Werror on typechecker warnings; we also want to run the desugarer + -- to get those warnings too. (But we'll always exit at that point + -- because the desugarer runs ioMsgMaybe.) + runHsc hsc_env $ do + e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage + mod_summary source_modified mb_old_iface mod_index + case e of + -- We didn't need to do any typechecking; the old interface + -- file on disk was good enough. + Left iface -> do + -- Knot tying! See Note [Knot-tying typecheckIface] + details <- liftIO . fixIO $ \details' -> do + let hsc_env' = + hsc_env { + hsc_HPT = addToHpt (hsc_HPT hsc_env) + (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing) + } + -- NB: This result is actually not that useful + -- in one-shot mode, since we're not going to do + -- any further typechecking. It's much more useful + -- in make mode, since this HMI will go into the HPT. + details <- genModDetails hsc_env' iface + return details + return (HscUpToDate iface details, dflags) + -- We finished type checking. (mb_old_hash is the hash of + -- the interface that existed on disk; it's possible we had + -- to retypecheck but the resulting interface is exactly + -- the same.) + Right (FrontendTypecheck tc_result, mb_old_hash) -> do + status <- finish mod_summary tc_result mb_old_hash + return (status, dflags) + +-- Runs the post-typechecking frontend (desugar and simplify). We want to +-- generate most of the interface as late as possible. This gets us up-to-date +-- and good unfoldings and other info in the interface file. +-- +-- We might create a interface right away, in which case we also return the +-- updated HomeModInfo. But we might also need to run the backend first. In the +-- later case Status will be HscRecomp and we return a function from ModIface -> +-- HomeModInfo. +-- +-- HscRecomp in turn will carry the information required to compute a interface +-- when passed the result of the code generator. So all this can and is done at +-- the call site of the backend code gen if it is run. +finish :: ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc HscStatus +finish summary tc_result mb_old_hash = do + hsc_env <- getHscEnv + let dflags = hsc_dflags hsc_env + target = hscTarget dflags + hsc_src = ms_hsc_src summary + + -- Desugar, if appropriate + -- + -- We usually desugar even when we are not generating code, otherwise we + -- would miss errors thrown by the desugaring (see #10600). The only + -- exceptions are when the Module is Ghc.Prim or when it is not a + -- HsSrcFile Module. + mb_desugar <- + if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile + then Just <$> hscDesugar' (ms_location summary) tc_result + else pure Nothing + + -- Simplify, if appropriate, and (whether we simplified or not) generate an + -- interface file. + case mb_desugar of + -- Just cause we desugared doesn't mean we are generating code, see above. + Just desugared_guts | target /= HscNothing -> do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + + (cg_guts, details) <- {-# SCC "CoreTidy" #-} + liftIO $ tidyProgram hsc_env simplified_guts + + let !partial_iface = + {-# SCC "GHC.Driver.Main.mkPartialIface" #-} + -- This `force` saves 2M residency in test T10370 + -- See Note [Avoiding space leaks in toIface*] for details. + force (mkPartialIface hsc_env details simplified_guts) + + return HscRecomp { hscs_guts = cg_guts, + hscs_mod_location = ms_location summary, + hscs_mod_details = details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash, + hscs_iface_dflags = dflags } + + -- We are not generating code, so we can skip simplification + -- and generate a simple interface. + _ -> do + (iface, mb_old_iface_hash, details) <- liftIO $ + hscSimpleIface hsc_env tc_result mb_old_hash + + liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) + + return $ case (target, hsc_src) of + (HscNothing, _) -> HscNotGeneratingCode iface details + (_, HsBootFile) -> HscUpdateBoot iface details + (_, HsigFile) -> HscUpdateSig iface details + _ -> panic "finish" + +{- +Note [Writing interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We write interface files in GHC.Driver.Main and GHC.Driver.Pipeline using +hscMaybeWriteIface, but only once per compilation (twice with dynamic-too). + +* If a compilation does NOT require (re)compilation of the hard code we call + hscMaybeWriteIface inside GHC.Driver.Main:finish. +* If we run in One Shot mode and target bytecode we write it in compileOne' +* Otherwise we must be compiling to regular hard code and require recompilation. + In this case we create the interface file inside RunPhase using the interface + generator contained inside the HscRecomp status. +-} +hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () +hscMaybeWriteIface dflags iface old_iface location = do + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = case hscTarget dflags of + HscNothing -> False + HscInterpreted -> False + _ -> True + no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) + + when (write_interface || force_write_interface) $ + hscWriteIface dflags iface no_change location + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + +-- NB: this must be knot-tied appropriately, see hscIncrementalCompile +genModDetails :: HscEnv -> ModIface -> IO ModDetails +genModDetails hsc_env old_iface + = do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceLoad hsc_env (typecheckIface old_iface) + dumpIfaceStats hsc_env + return new_details + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: HscEnv -> RecompileRequired -> IO () +oneShotMsg hsc_env recomp = + case recomp of + UpToDate -> + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + _ -> + return () + +batchMsg :: Messager +batchMsg hsc_env mod_index recomp mod_summary = + case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + where + dflags = hsc_dflags hsc_env + showMsg msg reason = + compilationProgressMsg dflags $ + (showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary) + ++ reason + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- Note [Safe Haskell Inference] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell does Safe inference on modules that don't have any specific +-- safe haskell mode flag. The basic approach to this is: +-- * When deciding if we need to do a Safe language check, treat +-- an unmarked module as having -XSafe mode specified. +-- * For checks, don't throw errors but return them to the caller. +-- * Caller checks if there are errors: +-- * For modules explicitly marked -XSafe, we throw the errors. +-- * For unmarked modules (inference mode), we drop the errors +-- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `-Wsafe`, `-Wunsafe` and +-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. + + +-- | Check that the safe imports of the module being compiled are valid. +-- If not we either issue a compilation error if the module is explicitly +-- using Safe Haskell, or mark the module as unsafe if we're in safe +-- inference mode. +hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv +hscCheckSafeImports tcg_env = do + dflags <- getDynFlags + tcg_env' <- checkSafeImports tcg_env + checkRULES dflags tcg_env' + + where + checkRULES dflags tcg_env' = do + case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logWarnings $ warns dflags (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + + warns dflags rules = listToBag $ map (warnRules dflags) rules + + warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg + warnRules dflags (L loc (HsRule { rd_name = n })) = + mkPlainWarnMsg dflags loc $ + text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ + text "User defined rules are disabled under Safe Haskell" + warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec + +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external package +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. +-- +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- GHC.Rename.Names.rnImportDecl for where package trust dependencies for a +-- module are collected and unioned. Specifically see the Note [Tracking Trust +-- Transitively] in GHC.Rename.Names and the Note [Trust Own Package] in +-- GHC.Rename.Names. +checkSafeImports :: TcGblEnv -> Hsc TcGblEnv +checkSafeImports tcg_env + = do + dflags <- getDynFlags + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + + -- We want to use the warning state specifically for detecting if safe + -- inference has failed, so store and clear any existing warnings. + oldErrs <- getWarnings + clearWarnings + + -- Check safe imports are correct + safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safeErrs <- getWarnings + clearWarnings + + -- Check non-safe imports are correct if inferring safety + -- See the Note [Safe Haskell Inference] + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyBag, S.empty) + True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + infErrs <- getWarnings + clearWarnings + return (infErrs, infPkgs) + + -- restore old errors + logWarnings oldErrs + + case (isEmptyBag safeErrs) of + -- Failed safe check + False -> liftIO . throwIO . mkSrcErr $ safeErrs + + -- Passed safe check + True -> do + let infPassed = isEmptyBag infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + + where + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods + imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) + imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) + pkgReqs = imp_trust_pkgs impInfo -- [UnitId] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" + condense (m, x:xs) = do imv <- foldlM cond' x xs + return (m, imv_span imv, imv_is_safe imv) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1 v2 + | imv_is_safe v1 /= imv_is_safe v2 + = do + dflags <- getDynFlags + throwOneError $ mkPlainErrMsg dflags (imv_span v1) + (text "Module" <+> ppr (imv_name v1) <+> + (text $ "is imported both as a safe and unsafe import!")) + | otherwise + = return v1 + + -- easier interface to work with + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId -> + Bool -> ImportAvails + pkgTrustReqs dflags req inf infPassed | safeInferOn dflags + && not (safeHaskellModeEnabled dflags) && infPassed + = emptyImportAvails { + imp_trust_pkgs = req `S.union` inf + } + pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } + +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' m l + when (packageTrustOn dflags) $ checkPkgTrust pkgs + errs <- getWarnings + return $ isEmptyBag errs + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId) +hscGetSafe hsc_env m l = runHsc hsc_env $ do + (self, pkgs) <- hscCheckSafe' m l + good <- isEmptyBag `fmap` getWarnings + clearWarnings -- don't want them printed... + let pkgs' | Just p <- self = S.insert p pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- Return (regardless of trusted or not) if the trust type requires the modules +-- own package be trusted and a list of other packages required to be trusted +-- (these later ones haven't been checked) but the own package trust has been. +hscCheckSafe' :: Module -> SrcSpan + -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) +hscCheckSafe' m l = do + dflags <- getDynFlags + (tw, pkgs) <- isModSafe m l + case tw of + False -> return (Nothing, pkgs) + True | isHomePkg dflags m -> return (Nothing, pkgs) + -- TODO: do we also have to check the trust of the instantiation? + -- Not necessary if that is reflected in dependencies + | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs) + where + isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId) + isModSafe m l = do + dflags <- getDynFlags + iface <- lookup' m + case iface of + -- can't load iface to check trust! + Nothing -> throwOneError $ mkPlainErrMsg dflags l + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" + + -- got iface, check trust + Just iface' -> + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted dflags trust trust_own_pkg m + -- pkg trust reqs + pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' + -- warn if Safe module imports Safe-Inferred module. + warns = if wopt Opt_WarnInferredSafeImports dflags + && safeLanguageOn dflags + && trust == Sf_SafeInferred + then inferredImportWarn + else emptyBag + -- General errors we throw but Safe errors we log + errs = case (safeM, safeP) of + (True, True ) -> emptyBag + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logWarnings warns + logWarnings errs + return (trust == Sf_Trustworthy, pkgRs) + + where + inferredImportWarn = unitBag + $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) + $ mkErrMsg dflags l (pkgQual dflags) + $ sep + [ text "Importing Safe-Inferred module " + <> ppr (moduleName m) + <> text " from explicitly Safe module" + ] + pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (moduleUnitId m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] + + -- | Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted _ Sf_None _ _ = False -- shouldn't hit these cases + packageTrusted _ Sf_Ignore _ _ = False -- shouldn't hit these cases + packageTrusted _ Sf_Unsafe _ _ = False -- prefer for completeness. + packageTrusted dflags _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted _ Sf_Safe False _ = True + packageTrusted _ Sf_SafeInferred False _ = True + packageTrusted dflags _ _ m + | isHomePkg dflags m = True + | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule homePkgT pkgIfaceT m + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + iface' <- case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + return iface' + + + isHomePkg :: DynFlags -> Module -> Bool + isHomePkg dflags m + | thisPackage dflags == moduleUnitId m = True + | otherwise = False + +-- | Check the list of packages are trusted. +checkPkgTrust :: Set InstalledUnitId -> Hsc () +checkPkgTrust pkgs = do + dflags <- getDynFlags + let errors = S.foldr go [] pkgs + go pkg acc + | trusted $ getInstalledPackageDetails dflags pkg + = acc + | otherwise + = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags) + $ text "The package (" <> ppr pkg <> text ") is required" <> + text " to be trusted but it isn't!" + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + +-- | Set module to unsafe and (potentially) wipe trust information. +-- +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do + dflags <- getDynFlags + + when (wopt Opt_WarnUnsafe dflags) + (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ + mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + + liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) + -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case not (safeHaskellModeEnabled dflags) of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env + + where + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ + (vcat $ badInsts $ tcg_insts tcg_env) + ] + badFlags df = concatMap (badFlag df) unsafeFlagsForInfer + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + badInsts insts = concatMap badInst insts + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) + = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ + ppr (overlapMode $ is_flag ins) <+> + text "overlap mode isn't 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 +-------------------------------------------------------------- + +hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts +hscSimplify hsc_env plugins modguts = + runHsc hsc_env $ hscSimplify' plugins modguts + +hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts +hscSimplify' plugins ds_result = do + hsc_env <- getHscEnv + let hsc_env_with_plugins = hsc_env + { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins + } + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env_with_plugins ds_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +-- | Generate a striped down interface file, e.g. for boot files or when ghci +-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +hscSimpleIface :: HscEnv + -> TcGblEnv + -> Maybe Fingerprint + -> IO (ModIface, Maybe Fingerprint, ModDetails) +hscSimpleIface hsc_env tc_result mb_old_iface + = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface + +hscSimpleIface' :: TcGblEnv + -> Maybe Fingerprint + -> Hsc (ModIface, Maybe Fingerprint, ModDetails) +hscSimpleIface' tc_result mb_old_iface = do + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result + new_iface + <- {-# SCC "MkFinalIface" #-} + liftIO $ + mkIfaceTc hsc_env safe_mode details tc_result + -- And the answer is ... + liftIO $ dumpIfaceStats hsc_env + return (new_iface, mb_old_iface, details) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- +{- +Note [Interface filename extensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +ModLocation only contains the base names, however when generating dynamic files +the actual extension might differ from the default. + +So we only load the base name from ModLocation and replace the actual extension +according to the information in DynFlags. + +If we generate a interface file right after running the core pipeline we will +have set -dynamic-too and potentially generate both interface files at the same +time. + +If we generate a interface file after running the backend then dynamic-too won't +be set, however then the extension will be contained in the dynflags instead so +things still work out fine. +-} + +hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO () +hscWriteIface dflags iface no_change mod_location = do + -- mod_location only contains the base name, so we rebuild the + -- correct file extension from the dynflags. + let ifaceBaseFile = ml_hi_file mod_location + unless no_change $ + let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags) + in {-# SCC "writeIface" #-} + writeIfaceFile dflags ifaceFile iface + whenGeneratingDynamicToo dflags $ do + -- TODO: We should do a no_change check for the dynamic + -- interface file too + -- When we generate iface files after core + let dynDflags = dynamicTooMkDynamicDynFlags dflags + -- dynDflags will have set hiSuf correctly. + dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags) + + writeIfaceFile dynDflags dynIfaceFile iface + where + buildIfName :: String -> String -> String + buildIfName baseName suffix + | Just name <- outputHi dflags + = name + | otherwise + = let with_hi = replaceExtension baseName suffix + in addBootSuffix_maybe (mi_boot iface) with_hi + +-- | Compile to hard-code. +hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) + -- ^ @Just f@ <=> _stub.c is f +hscGenHardCode hsc_env cgguts location output_filename = do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info } = cgguts + dflags = hsc_dflags hsc_env + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env this_mod location + core_binds data_tycons + ----------------- Convert to STG ------------------ + (stg_binds, (caf_ccs, caf_cc_stacks)) + <- {-# SCC "CoreToStg" #-} + myCoreToStg dflags this_mod prepd_binds + + let cost_centre_info = + (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + prof_init = profilingInitCode this_mod cost_centre_info + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + + ------------------ Code generation ------------------ + + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so showPass isn't very useful here. + -- Hence we have one showPass for the whole backend, the + -- next showPass after this will be "Assembler". + withTiming dflags + (text "CodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + lookupHook cmmToRawCmmHook + (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms + + let dump a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos) + <- {-# SCC "codeOutput" #-} + codeOutput dflags this_mod output_filename location + foreign_stubs foreign_files dependencies rawcmms1 + return (output_filename, stub_c_exists, foreign_fps, caf_infos) + + +hscInteractive :: HscEnv + -> CgGuts + -> ModLocation + -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) +hscInteractive hsc_env cgguts location = do + let dflags = hsc_dflags hsc_env + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks, + cg_spt_entries = spt_entries } = cgguts + + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env this_mod location core_binds data_tycons + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks + ------------------ Create f-x-dynamic C-side stuff ----- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs + return (istub_c_exists, comp_bc, spt_entries) + +------------------------------ + +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + cmm <- ioMsgMaybe $ parseCmmFile dflags filename + liftIO $ do + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) + let -- Make up a module name to give the NCG. We can't pass bottom here + -- lest we reproduce #11784. + mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename + cmm_mod = mkModule (thisPackage dflags) mod_name + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- Re-ordering here causes breakage when booting with C backend because + -- in C we must declare before use, but SRT algorithm is free to + -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] + cmmgroup <- + concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm + + unless (null cmmgroup) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" + FormatCMM (ppr cmmgroup) + rawCmms <- lookupHook cmmToRawCmmHook + (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) + _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] + rawCmms + return () + where + no_loc = ModLocation{ ml_hs_file = Just filename, + ml_hi_file = panic "hscCompileCmmFile: no hi file", + ml_obj_file = panic "hscCompileCmmFile: no obj file", + ml_hie_file = panic "hscCompileCmmFile: no hie file"} + +-------------------- Stuff for new code gen --------------------- + +{- +Note [Forcing of stg_binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The two last steps in the STG pipeline are: + +* Sorting the bindings in dependency order. +* Annotating them with free variables. + +We want to make sure we do not keep references to unannotated STG bindings +alive, nor references to bindings which have already been compiled to Cmm. + +We explicitly force the bindings to avoid this. + +This reduces residency towards the end of the CodeGen phase significantly +(5-10%). +-} + +doCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [StgTopBinding] + -> HpcInfo + -> IO (Stream IO CmmGroupSRTs NameSet) + -- Note we produce a 'Stream' of CmmGroups, so that the + -- backend can be run incrementally. Otherwise it generates all + -- the C-- up front, which has a significant space cost. +doCodeGen hsc_env this_mod data_tycons + cost_centre_info stg_binds hpc_info = do + let dflags = hsc_dflags hsc_env + + let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds + + dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs) + + let cmm_stream :: Stream IO CmmGroup () + -- See Note [Forcing of stg_binds] + cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} + lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons + cost_centre_info stg_binds_w_fvs hpc_info + + -- codegen consumes a stream of CmmGroup, and produces a new + -- stream of CmmGroup (not necessarily synchronised: one + -- CmmGroup on input may produce many CmmGroups on output due + -- to proc-point splitting). + + let dump1 a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg + "Cmm produced by codegen" FormatCMM (ppr a) + return a + + ppr_stream1 = Stream.mapM dump1 cmm_stream + + pipeline_stream = + {-# SCC "cmmPipeline" #-} + Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + <&> (srtMapNonCAFs . moduleSRTMap) + + dump2 a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) + return a + + return (Stream.mapM dump2 pipeline_stream) + +myCoreToStg :: DynFlags -> Module -> CoreProgram + -> IO ( [StgTopBinding] -- output program + , CollectedCCs ) -- CAF cost centre info (declared and used) +myCoreToStg dflags this_mod prepd_binds = do + let (stg_binds, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg dflags this_mod prepd_binds + + stg_binds2 + <- {-# SCC "Stg2Stg" #-} + stg2stg dflags this_mod stg_binds + + return (stg_binds2, cost_centre_info) + + +{- ********************************************************************** +%* * +\subsection{Compiling a do-statement} +%* * +%********************************************************************* -} + +{- +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types +-} + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmtWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt + case maybe_stmt of + Nothing -> return Nothing + + Just parsed_stmt -> do + hsc_env <- getHscEnv + liftIO $ hscParsedStmt hsc_env parsed_stmt + +hscParsedStmt :: HscEnv + -> GhciLStmt GhcPs -- ^ The parsed statement + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do + -- Rename and typecheck it + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt + + -- Desugar it + ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr + liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) + handleWarnings + + -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisUnitId + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' + let src_span = srcLocSpan interactiveSrcLoc + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + + return $ Just (ids, hval, fix_env) + +-- | Compile a decls +hscDecls :: HscEnv + -> String -- ^ The statement + -> IO ([TyThing], InteractiveContext) +hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1 + +hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] +hscParseDeclsWithLocation hsc_env source line_num str = do + L _ (HsModule{ hsmodDecls = decls }) <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source line_num parseModule str + return decls + +-- | Compile a decls +hscDeclsWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ([TyThing], InteractiveContext) +hscDeclsWithLocation hsc_env str source linenumber = do + L _ (HsModule{ hsmodDecls = decls }) <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source linenumber parseModule str + hscParsedDecls hsc_env decls + +hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) +hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do + {- Rename and typecheck it -} + hsc_env <- getHscEnv + tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls + + {- Grab the new instances -} + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let defaults = tcg_default tc_gblenv + + {- Desugar it -} + -- We use a basically null location for iNTERACTIVE + let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", + ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file", + ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" } + ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv + + {- Simplify -} + simpl_mg <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tc_gblenv) + hscSimplify hsc_env plugins ds_result + + {- Tidy -} + (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg + + let !CgGuts{ cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_modBreaks = mod_breaks } = tidy_cg + + !ModDetails { md_insts = cls_insts + , md_fam_insts = fam_insts } = mod_details + -- Get the *tidied* cls_insts and fam_insts + + data_tycons = filter isDataTyCon tycons + + {- Prepare For Code Generation -} + -- Do saturation and convert to A-normal form + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons + + {- Generate byte code -} + cbc <- liftIO $ byteCodeGen hsc_env this_mod + prepd_binds data_tycons mod_breaks + + let src_span = srcLocSpan interactiveSrcLoc + liftIO $ linkDecls hsc_env src_span cbc + + {- Load static pointer table entries -} + liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) + patsyns = mg_patsyns simpl_mg + + ext_ids = [ id | id <- bindersOfBinds core_binds + , isExternalName (idName id) + , not (isDFunId id || isImplicitId id) ] + -- We only need to keep around the external bindings + -- (as decided by GHC.Iface.Tidy), since those are the only ones + -- that might later be looked up by name. But we can exclude + -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types + -- - Implicit Ids, which are implicit in tcs + -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv + + new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns + ictxt = hsc_IC hsc_env + -- See Note [Fixity declarations in GHCi] + fix_env = tcg_fix_env tc_gblenv + new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts + fam_insts defaults fix_env + return (new_tythings, new_ictxt) + +-- | Load the given static-pointer table entries into the interpreter. +-- See Note [Grand plan for static forms] in StaticPtrTable. +hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () +hscAddSptEntries hsc_env entries = do + let add_spt_entry :: SptEntry -> IO () + add_spt_entry (SptEntry i fpr) = do + val <- getHValue hsc_env (idName i) + addSptEntry hsc_env fpr val + mapM_ add_spt_entry entries + +{- + Note [Fixity declarations in GHCi] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + To support fixity declarations on types defined within GHCi (as requested + in #10018) we record the fixity environment in InteractiveContext. + When we want to evaluate something TcRnDriver.runTcInteractive pulls out this + fixity environment and uses it to initialize the global typechecker environment. + After the typechecker has finished its business, an updated fixity environment + (reflecting whatever fixity declarations were present in the statements we + passed it) will be returned from hscParsedStmt. This is passed to + updateFixityEnv, which will stuff it back into InteractiveContext, to be + used in evaluating the next statement. + +-} + +hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) +hscImport hsc_env str = runInteractiveHsc hsc_env $ do + (L _ (HsModule{hsmodImports=is})) <- + hscParseThing parseModule str + case is of + [L _ i] -> return i + _ -> liftIO $ throwOneError $ + mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ + text "parse error in import declaration" + +-- | Typecheck an expression (but don't run it) +hscTcExpr :: HscEnv + -> TcRnExprMode + -> String -- ^ The expression + -> IO Type +hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + parsed_expr <- hscParseExpr expr + ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr + +-- | Find the kind of a type, after generalisation +hscKcType + :: HscEnv + -> Bool -- ^ Normalise the type + -> String -- ^ The type as a string + -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty + +hscParseExpr :: String -> Hsc (LHsExpr GhcPs) +hscParseExpr expr = do + hsc_env <- getHscEnv + maybe_stmt <- hscParseStmt expr + case maybe_stmt of + Just (L _ (BodyStmt _ expr _ _)) -> return expr + _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan + (text "not an expression:" <+> quotes (text expr)) + +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmt = hscParseThing parseStmt + +hscParseStmtWithLocation :: String -> Int -> String + -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType GhcPs) +hscParseType = hscParseThing parseType + +hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier hsc_env str = + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str + +hscParseThing :: (Outputable thing, Data thing) + => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "<interactive>" 1 + +hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int + -> Lexer.P thing -> String -> Hsc thing +hscParseThingWithLocation source linenumber parser str + = withTimingD + (text "Parser [source]") + (const ()) $ {-# SCC "Parser" #-} do + dflags <- getDynFlags + + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 + + case unP parser (mkPState dflags buf loc) of + PFailed pst -> do + handleWarningsThrowErrors (getMessages pst dflags) + + POk pst thing -> do + logWarningsReportErrors (getMessages pst dflags) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan thing) + return thing + + +{- ********************************************************************** +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%********************************************************************* -} + +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr hsc_env = + lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env + +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr' hsc_env srcspan ds_expr + = do { let dflags = hsc_dflags hsc_env + + {- Simplify it -} + ; simpl_expr <- simplifyExpr hsc_env ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos + + ; return hval } + + +{- ********************************************************************** +%* * + Statistics on reading interfaces +%* * +%********************************************************************* -} + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env = do + eps <- readIORef (hsc_EPS hsc_env) + dumpIfSet dflags (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) + where + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags + + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> String +showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " + where + n_str = show n + i_str = show i + padded = replicate (length n_str - length i_str) ' ' ++ i_str diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs new file mode 100644 index 0000000000..e1aa392771 --- /dev/null +++ b/compiler/GHC/Driver/Make.hs @@ -0,0 +1,2739 @@ +{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- +module GHC.Driver.Make ( + depanal, depanalE, depanalPartial, + load, load', LoadHowMuch(..), + + downsweep, + + topSortModuleGraph, + + ms_home_srcimps, ms_home_imps, + + IsBoot(..), + summariseModule, + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirements, + + noModError, cyclicModuleErr, + moduleGraphNodes, SummaryNode + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import qualified GHC.Runtime.Linker as Linker + +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Session +import ErrUtils +import GHC.Driver.Finder +import GHC.Driver.Monad +import HeaderInfo +import GHC.Driver.Types +import Module +import GHC.IfaceToCore ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) +import GHC.Driver.Main + +import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import BasicTypes +import Digraph +import Exception ( tryIO, gbracket, gfinally ) +import FastString +import Maybes ( expectJust ) +import Name +import MonadUtils ( allM ) +import Outputable +import Panic +import SrcLoc +import StringBuffer +import UniqFM +import UniqDSet +import TcBackpack +import GHC.Driver.Packages +import UniqSet +import Util +import qualified GHC.LanguageExtensions as LangExt +import NameEnv +import FileCleanup + +import Data.Either ( rights, partitionEithers ) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import qualified FiniteMap as Map ( insertListWith ) + +import Control.Concurrent ( forkIOWithUnmask, killThread ) +import qualified GHC.Conc as CC +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) +import Data.IORef +import Data.List +import qualified Data.List as List +import Data.Foldable (toList) +import Data.Maybe +import Data.Ord ( comparing ) +import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) + +import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) + +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- In case of errors, just throw them. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots + if isEmptyBag errs + then pure mod_graph + else throwErrors errs + +-- | Perform dependency analysis like in 'depanal'. +-- In case of errors, the errors and an empty module graph are returned. +depanalE :: GhcMonad m => -- New for #17459 + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) +depanalE excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots + if isEmptyBag errs + then do + warnMissingHomeModules hsc_env mod_graph + setSession hsc_env { hsc_mod_graph = mod_graph } + pure (errs, mod_graph) + else do + -- We don't have a complete module dependency graph, + -- The graph may be disconnected and is unusable. + setSession hsc_env { hsc_mod_graph = emptyMG } + pure (errs, emptyMG) + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + withTiming dflags (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + -- Home package modules may have been moved or deleted, and new + -- source files may have appeared in the home package that shadow + -- external package modules, so we have to discard the existing + -- cached finder data. + liftIO $ flushFinderCaches hsc_env + + mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph) + excluded_mods allow_dup_roots + let + (errs, mod_summaries) = partitionEithers mod_summariesE + mod_graph = mkModuleGraph mod_summaries + return (unionManyBags errs, mod_graph) + +-- Note [Missing home modules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed +-- in a command line. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns user about modules, not listed +-- neither in `exposed-modules`, nor in `other-modules`. +-- +-- Here "home module" means a module, that doesn't come from an other package. +-- +-- For example, if GHC is invoked with modules "A" and "B" as targets, +-- but "A" imports some other module "C", then GHC will issue a warning +-- about module "C" not being listed in a command line. +-- +-- The warning in enabled by `-Wmissing-home-modules`. See #13129 +warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () +warnMissingHomeModules hsc_env mod_graph = + when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $ + logWarnings (listToBag [warn]) + where + dflags = hsc_dflags hsc_env + targets = map targetId (hsc_targets hsc_env) + + is_known_module mod = any (is_my_target mod) targets + + -- We need to be careful to handle the case where (possibly + -- path-qualified) filenames (aka 'TargetFile') rather than module + -- names are being passed on the GHC command-line. + -- + -- For instance, `ghc --make src-exe/Main.hs` and + -- `ghc --make -isrc-exe Main` are supposed to be equivalent. + -- Note also that we can't always infer the associated module name + -- directly from the filename argument. See #13727. + is_my_target mod (TargetModule name) + = moduleName (ms_mod mod) == name + is_my_target mod (TargetFile target_file _) + | Just mod_file <- ml_hs_file (ms_location mod) + = target_file == mod_file || + + -- Don't warn on B.hs-boot if B.hs is specified (#16551) + addBootSuffix target_file == mod_file || + + -- We can get a file target even if a module name was + -- originally specified in a command line because it can + -- be converted in guessTarget (by appending .hs/.lhs). + -- So let's convert it back and compare with module name + mkModuleName (fst $ splitExtension target_file) + == moduleName (ms_mod mod) + is_my_target _ _ = False + + missing = map (moduleName . ms_mod) $ + filter (not . is_known_module) (mgModSummaries mod_graph) + + msg + | gopt Opt_BuildingCabalPackage dflags + = hang + (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ") + 4 + (sep (map ppr missing)) + | otherwise + = + hang + (text "Modules are not listed in command line but needed for compilation: ") + 4 + (sep (map ppr missing)) + warn = makeIntoWarning + (Reason Opt_WarnMissingHomeModules) + (mkPlainErrMsg dflags noSrcSpan msg) + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compiling +-- and loading may result in files being created on disk. +-- +-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether +-- successful or not. +-- +-- If errors are encountered during dependency analysis, the module `depanalE` +-- returns together with the errors an empty ModuleGraph. +-- After processing this empty ModuleGraph, the errors of depanalE are thrown. +-- All other errors are reported using the 'defaultWarnErrLogger'. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + (errs, mod_graph) <- depanalE [] False -- #17459 + success <- load' how_much (Just batchMsg) mod_graph + warnUnusedPackages + if isEmptyBag errs + then pure success + else throwErrors errs + +-- Note [Unused packages] +-- +-- Cabal passes `--package-id` flag for each direct dependency. But GHC +-- loads them lazily, so when compilation is done, we have a list of all +-- actually loaded packages. All the packages, specified on command line, +-- but never loaded, are probably unused dependencies. + +warnUnusedPackages :: GhcMonad m => m () +warnUnusedPackages = do + hsc_env <- getSession + eps <- liftIO $ hscEPS hsc_env + + let dflags = hsc_dflags hsc_env + pit = eps_PIT eps + + let loadedPackages + = map (getPackageDetails dflags) + . nub . sort + . map moduleUnitId + . moduleEnvKeys + $ pit + + requestedArgs = mapMaybe packageArg (packageFlags dflags) + + unusedArgs + = filter (\arg -> not $ any (matching dflags arg) loadedPackages) + requestedArgs + + let warn = makeIntoWarning + (Reason Opt_WarnUnusedPackages) + (mkPlainErrMsg dflags noSrcSpan msg) + msg = vcat [ text "The following packages were specified" <+> + text "via -package or -package-id flags," + , text "but were not needed for compilation:" + , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] + + when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $ + logWarnings (listToBag [warn]) + + where + packageArg (ExposePackage _ arg _) = Just arg + packageArg _ = Nothing + + pprUnusedArg (PackageArg str) = text str + pprUnusedArg (UnitIdArg uid) = ppr uid + + withDash = (<+>) (text "-") + + matchingStr :: String -> UnitInfo -> Bool + matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + + matching :: DynFlags -> PackageArg -> UnitInfo -> Bool + matching _ (PackageArg str) p = matchingStr str p + matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p + + -- For wired-in packages, we have to unwire their id, + -- otherwise they won't match package flags + realUnitId :: DynFlags -> UnitInfo -> UnitId + realUnitId dflags + = unwireUnitId dflags + . DefiniteUnitId + . DefUnitId + . installedUnitInfoId + +-- | Generalized version of 'load' which also supports a custom +-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally +-- produced by calling 'depanal'. +load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' how_much mHscMessage mod_graph = do + modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = + mkUniqSet [ ms_mod_name s + | s <- mgModSummaries mod_graph, not (isBootSummary s)] + -- TODO: Figure out what the correct form of this assert is. It's violated + -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot + -- files without corresponding hs files. + -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + -- not (ms_mod_name s `elem` all_home_mods)] + -- ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elementOfUniqSet` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- nonDetEltsUniqSet stable_obj ++ + nonDetEltsUniqSet stable_bco, + -- It's OK to use nonDetEltsUniqSet here + -- because it only affects linking. Besides + -- this list only serves as a poor man's set. + Just hmi <- [lookupHpt pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + stable_mod_summary ms ] + + stable_mod_summary ms = + ms_mod_name ms `elementOfUniqSet` stable_obj || + ms_mod_name ms `elementOfUniqSet` stable_bco + + -- the modules from partial_mg that are not also stable + -- NB. also keep cycles, we need to emit an error message later + unstable_mg = filter not_stable partial_mg + where not_stable (CyclicSCC _) = True + not_stable (AcyclicSCC ms) + = not $ stable_mod_summary ms + + -- Load all the stable modules first, before attempting to load + -- an unstable module (#7231). + mg = stable_mg ++ unstable_mg + + -- clean up between compilations + let cleanup = cleanCurrentModuleTempFiles . hsc_dflags + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + n_jobs <- case parMakeCount dflags of + Nothing -> liftIO getNumProcessors + Just n -> return n + let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs + | otherwise = upsweep + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ + upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ cleanCurrentModuleTempFiles dflags + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = gopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = mgElemModule mod_graph main_mod + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + if ghcLink dflags == LinkBinary && isJust ofile && not do_linking + then do + liftIO $ errorMsg dflags $ text + ("output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + -- This should be an error, not a warning (#10895). + loadFinish Failed linkresult + else + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let (mods_to_clean, mods_to_keep) = + partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone + hsc_env1 <- getSession + let hpt4 = hsc_HPT hsc_env1 + -- We must change the lifetime to TFL_CurrentModule for any temp + -- file created for an element of mod_to_clean during the upsweep. + -- These include preprocessed files and object files for loaded + -- modules. + unneeded_temps = concat + [ms_hspp_file : object_files + | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean + , let object_files = maybe [] linkableObjs $ + lookupHpt hpt4 (moduleName ms_mod) + >>= hm_linkable + ] + liftIO $ + changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps + liftIO $ cleanCurrentModuleTempFiles dflags + + let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + hpt4 + + -- Clean up after ourselves + + -- there should be no Nothings where linkables should be, now + let just_linkables = + isNoLink (ghcLink dflags) + || allHpt (isJust.hm_linkable) + (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface) + hpt5) + ASSERT( just_linkables ) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } + loadFinish Failed linkresult + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag + +-- If the link failed, unload everything and return. +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession discardIC + return all_ok + + +-- | Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags. +-- It will also keep ic_int_print and ic_monad if their names are from +-- external packages. +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print + , ic_monad = new_ic_monad } } + where + -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic + !new_ic_int_print = keep_external_name ic_int_print + !new_ic_monad = keep_external_name ic_monad + dflags = ic_dflags old_ic + old_ic = hsc_IC hsc_env + empty_ic = emptyInteractiveContext dflags + keep_external_name ic_name + | nameIsFromExternalPackage this_pkg old_name = old_name + | otherwise = ic_name empty_ic + where + this_pkg = thisPackage dflags + old_name = ic_name old_ic + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + -- Force mod_graph to avoid leaking env + !mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + ms <- mgLookupModule mod_graph (mainModIs dflags) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + + name_exe = do +#if defined(mingw32_HOST_OS) + -- we must add the .exe extension unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 + name' <- fmap (<.> "exe") name +#else + name' <- name +#endif + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- +-- +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. +pruneHomePackageTable :: HomePackageTable + -> [ModSummary] + -> StableModules + -> HomePackageTable +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapHpt prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = + m `elementOfUniqSet` stable_obj || + m `elementOfUniqSet` stable_bco + +-- ----------------------------------------------------------------------------- +-- +-- | Return (names of) all those in modsDone who are part of a cycle as defined +-- by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module +findPartiallyCompletedCycles modsDone theGraph + = Set.unions + [mods_in_this_cycle + | CyclicSCC vs <- theGraph -- Acyclic? Not interesting. + , let names_in_this_cycle = Set.fromList (map ms_mod vs) + mods_in_this_cycle = + Set.intersection (Set.fromList modsDone) names_in_this_cycle + -- If size mods_in_this_cycle == size names_in_this_cycle, + -- then this cycle has already been completed and we're not + -- interested. + , Set.size mods_in_this_cycle < Set.size names_in_this_cycle] + + +-- --------------------------------------------------------------------------- +-- +-- | Unloading +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of + LinkInMemory -> Linker.unload hsc_env stable_linkables + _other -> return () + +-- ----------------------------------------------------------------------------- +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. + + - Note that even if an object is stable, we may end up recompiling + if the interface is out of date because an *external* interface + has changed. The current code in GHC.Driver.Make handles this case + fairly poorly, so be careful. +-} + +type StableModules = + ( UniqSet ModuleName -- stableObject + , UniqSet ModuleName -- stableBCO + ) + + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> UniqSet ModuleName -- all home modules + -> StableModules + +checkStability hpt sccs all_home_mods = + foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs + where + checkSCC :: StableModules -> SCC ModSummary -> StableModules + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco) + | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = + m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps + stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearest second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + -- + -- But see #5527, where someone ran into this and it caused + -- a problem. + + bco_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | otherwise = case lookupHpt hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +{- Parallel Upsweep + - + - The parallel upsweep attempts to concurrently compile the modules in the + - compilation graph using multiple Haskell threads. + - + - The Algorithm + - + - A Haskell thread is spawned for each module in the module graph, waiting for + - its direct dependencies to finish building before it itself begins to build. + - + - Each module is associated with an initially empty MVar that stores the + - result of that particular module's compile. If the compile succeeded, then + - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that + - module, and the module's HMI is deleted from the old HPT (synchronized by an + - IORef) to save space. + - + - Instead of immediately outputting messages to the standard handles, all + - compilation output is deferred to a per-module TQueue. A QSem is used to + - limit the number of workers that are compiling simultaneously. + - + - Meanwhile, the main thread sequentially loops over all the modules in the + - module graph, outputting the messages stored in each module's TQueue. +-} + +-- | Each module is given a unique 'LogQueue' to redirect compilation messages +-- to. A 'Nothing' value contains the result of compilation, and denotes the +-- end of the message queue. +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)]) + !(MVar ()) + +-- | The graph of modules to compile and their corresponding result 'MVar' and +-- 'LogQueue'. +type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)] + +-- | Build a 'CompilationGraph' out of a list of strongly-connected modules, +-- also returning the first, if any, encountered module cycle. +buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary]) +buildCompGraph [] = return ([], Nothing) +buildCompGraph (scc:sccs) = case scc of + AcyclicSCC ms -> do + mvar <- newEmptyMVar + log_queue <- do + ref <- newIORef [] + sem <- newEmptyMVar + return (LogQueue ref sem) + (rest,cycle) <- buildCompGraph sccs + return ((ms,mvar,log_queue):rest, cycle) + CyclicSCC mss -> return ([], Just mss) + +-- A Module and whether it is a boot module. +type BuildModule = (Module, IsBoot) + +-- | 'Bool' indicating if a module is a boot module or not. We need to treat +-- boot modules specially when building compilation graphs, since they break +-- cycles. Regular source files and signature files are treated equivalently. +data IsBoot = IsBoot | NotBoot + deriving (Ord, Eq, Show, Read) + +-- | Tests if an 'HscSource' is a boot file, primarily for constructing +-- elements of 'BuildModule'. +hscSourceToIsBoot :: HscSource -> IsBoot +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot + +mkBuildModule :: ModSummary -> BuildModule +mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot) + +-- | The entry point to the parallel upsweep. +-- +-- See also the simpler, sequential 'upsweep'. +parUpsweep + :: GhcMonad m + => Int + -- ^ The number of workers we wish to run in parallel + -> Maybe Messager + -> HomePackageTable + -> StableModules + -> (HscEnv -> IO ()) + -> [SCC ModSummary] + -> m (SuccessFlag, + [ModSummary]) +parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + when (not (null (unitIdsToCheck dflags))) $ + throwGhcException (ProgramError "Backpack typechecking not supported with -j") + + -- The bits of shared state we'll be using: + + -- The global HscEnv is updated with the module's HMI when a module + -- successfully compiles. + hsc_env_var <- liftIO $ newMVar hsc_env + + -- The old HPT is used for recompilation checking in upsweep_mod. When a + -- module successfully gets compiled, its HMI is pruned from the old HPT. + old_hpt_var <- liftIO $ newIORef old_hpt + + -- What we use to limit parallelism with. + par_sem <- liftIO $ newQSem n_jobs + + + let updNumCapabilities = liftIO $ do + n_capabilities <- getNumCapabilities + n_cpus <- getNumProcessors + -- Setting number of capabilities more than + -- CPU count usually leads to high userspace + -- lock contention. #9221 + let n_caps = min n_jobs n_cpus + unless (n_capabilities /= 1) $ setNumCapabilities n_caps + return n_capabilities + -- Reset the number of capabilities once the upsweep ends. + let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n + + gbracket updNumCapabilities resetNumCapabilities $ \_ -> do + + -- Sync the global session with the latest HscEnv once the upsweep ends. + let finallySyncSession io = io `gfinally` do + hsc_env <- liftIO $ readMVar hsc_env_var + setSession hsc_env + + finallySyncSession $ do + + -- Build the compilation graph out of the list of SCCs. Module cycles are + -- handled at the very end, after some useful work gets done. Note that + -- this list is topologically sorted (by virtue of 'sccs' being sorted so). + (comp_graph,cycle) <- liftIO $ buildCompGraph sccs + let comp_graph_w_idx = zip comp_graph [1..] + + -- The list of all loops in the compilation graph. + -- NB: For convenience, the last module of each loop (aka the module that + -- finishes the loop) is prepended to the beginning of the loop. + let graph = map fstOf3 (reverse comp_graph) + boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms] + comp_graph_loops = go graph boot_modules + where + remove ms bm + | isBootSummary ms = delModuleSet bm (ms_mod ms) + | otherwise = bm + go [] _ = [] + go mg@(ms:mss) boot_modules + | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules) + = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules) + | otherwise + = go mss (remove ms boot_modules) + + -- Build a Map out of the compilation graph with which we can efficiently + -- look up the result MVar associated with a particular home module. + let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int) + home_mod_map = + Map.fromList [ (mkBuildModule ms, (mvar, idx)) + | ((ms,mvar,_),idx) <- comp_graph_w_idx ] + + + liftIO $ label_self "main --make thread" + -- For each module in the module graph, spawn a worker thread that will + -- compile this module. + let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> + forkIOWithUnmask $ \unmask -> do + liftIO $ label_self $ unwords + [ "worker --make thread" + , "for module" + , show (moduleNameString (ms_mod_name mod)) + , "number" + , show mod_idx + ] + -- Replace the default log_action with one that writes each + -- message to the module's log_queue. The main thread will + -- deal with synchronously printing these messages. + -- + -- Use a local filesToClean var so that we can clean up + -- intermediate files in a timely fashion (as soon as + -- compilation for that module is finished) without having to + -- worry about accidentally deleting a simultaneous compile's + -- important files. + lcl_files_to_clean <- newIORef emptyFilesToClean + let lcl_dflags = dflags { log_action = parLogAction log_queue + , filesToClean = lcl_files_to_clean } + + -- Unmask asynchronous exceptions and perform the thread-local + -- work to compile the module (see parUpsweep_one). + m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ + parUpsweep_one mod home_mod_map comp_graph_loops + lcl_dflags mHscMessage cleanup + par_sem hsc_env_var old_hpt_var + stable_mods mod_idx (length sccs) + + res <- case m_res of + Right flag -> return flag + Left exc -> do + -- Don't print ThreadKilled exceptions: they are used + -- to kill the worker thread in the event of a user + -- interrupt, and the user doesn't have to be informed + -- about that. + when (fromException exc /= Just ThreadKilled) + (errorMsg lcl_dflags (text (show exc))) + return Failed + + -- Populate the result MVar. + putMVar mvar res + + -- Write the end marker to the message queue, telling the main + -- thread that it can stop waiting for messages from this + -- particular compile. + writeLogQueue log_queue Nothing + + -- Add the remaining files that weren't cleaned up to the + -- global filesToClean ref, for cleanup later. + FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } <- readIORef (filesToClean lcl_dflags) + addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files + addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files + + -- Kill all the workers, masking interrupts (since killThread is + -- interruptible). XXX: This is not ideal. + ; killWorkers = uninterruptibleMask_ . mapM_ killThread } + + + -- Spawn the workers, making sure to kill them later. Collect the results + -- of each compile. + results <- liftIO $ bracket spawnWorkers killWorkers $ \_ -> + -- Loop over each module in the compilation graph in order, printing + -- each message from its log_queue. + forM comp_graph $ \(mod,mvar,log_queue) -> do + printLogs dflags log_queue + result <- readMVar mvar + if succeeded result then return (Just mod) else return Nothing + + + -- Collect and return the ModSummaries of all the successful compiles. + -- NB: Reverse this list to maintain output parity with the sequential upsweep. + let ok_results = reverse (catMaybes results) + + -- Handle any cycle in the original compilation graph and return the result + -- of the upsweep. + case cycle of + Just mss -> do + liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) + return (Failed,ok_results) + Nothing -> do + let success_flag = successIf (all isJust results) + return (success_flag,ok_results) + + where + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () + writeLogQueue (LogQueue ref sem) msg = do + atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) + _ <- tryPutMVar sem () + return () + + -- The log_action callback that is used to synchronize messages from a + -- worker thread. + parLogAction :: LogQueue -> LogAction + parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do + writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg)) + + -- Print each message from the log_queue using the log_action from the + -- session's DynFlags. + printLogs :: DynFlags -> LogQueue -> IO () + printLogs !dflags (LogQueue ref sem) = read_msgs + where read_msgs = do + takeMVar sem + msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) + print_loop msgs + + print_loop [] = read_msgs + print_loop (x:xs) = case x of + Just (reason,severity,srcSpan,style,msg) -> do + putLogMsg dflags reason severity srcSpan style msg + print_loop xs + -- Exit the loop once we encounter the end marker. + Nothing -> return () + +-- The interruptible subset of the worker threads' work. +parUpsweep_one + :: ModSummary + -- ^ The module we wish to compile + -> Map BuildModule (MVar SuccessFlag, Int) + -- ^ The map of home modules and their result MVar + -> [[BuildModule]] + -- ^ The list of all module loops within the compilation graph. + -> DynFlags + -- ^ The thread-local DynFlags + -> Maybe Messager + -- ^ The messager + -> (HscEnv -> IO ()) + -- ^ The callback for cleaning up intermediate files + -> QSem + -- ^ The semaphore for limiting the number of simultaneous compiles + -> MVar HscEnv + -- ^ The MVar that synchronizes updates to the global HscEnv + -> IORef HomePackageTable + -- ^ The old HPT + -> StableModules + -- ^ Sets of stable objects and BCOs + -> Int + -- ^ The index of this module + -> Int + -- ^ The total number of modules + -> IO SuccessFlag + -- ^ The result of this compile +parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem + hsc_env_var old_hpt_var stable_mods mod_index num_mods = do + + let this_build_mod = mkBuildModule mod + + let home_imps = map unLoc $ ms_home_imps mod + let home_src_imps = map unLoc $ ms_home_srcimps mod + + -- All the textual imports of this module. + let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $ + zip home_imps (repeat NotBoot) ++ + zip home_src_imps (repeat IsBoot) + + -- Dealing with module loops + -- ~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- Not only do we have to deal with explicit textual dependencies, we also + -- have to deal with implicit dependencies introduced by import cycles that + -- are broken by an hs-boot file. We have to ensure that: + -- + -- 1. A module that breaks a loop must depend on all the modules in the + -- loop (transitively or otherwise). This is normally always fulfilled + -- by the module's textual dependencies except in degenerate loops, + -- e.g.: + -- + -- A.hs imports B.hs-boot + -- B.hs doesn't import A.hs + -- C.hs imports A.hs, B.hs + -- + -- In this scenario, getModLoop will detect the module loop [A,B] but + -- the loop finisher B doesn't depend on A. So we have to explicitly add + -- A in as a dependency of B when we are compiling B. + -- + -- 2. A module that depends on a module in an external loop can't proceed + -- until the entire loop is re-typechecked. + -- + -- These two invariants have to be maintained to correctly build a + -- compilation graph with one or more loops. + + + -- The loop that this module will finish. After this module successfully + -- compiles, this loop is going to get re-typechecked. + let finish_loop = listToMaybe + [ tail loop | loop <- comp_graph_loops + , head loop == this_build_mod ] + + -- If this module finishes a loop then it must depend on all the other + -- modules in that loop because the entire module loop is going to be + -- re-typechecked once this module gets compiled. These extra dependencies + -- are this module's "internal" loop dependencies, because this module is + -- inside the loop in question. + let int_loop_deps = Set.fromList $ + case finish_loop of + Nothing -> [] + Just loop -> filter (/= this_build_mod) loop + + -- If this module depends on a module within a loop then it must wait for + -- that loop to get re-typechecked, i.e. it must wait on the module that + -- finishes that loop. These extra dependencies are this module's + -- "external" loop dependencies, because this module is outside of the + -- loop(s) in question. + let ext_loop_deps = Set.fromList + [ head loop | loop <- comp_graph_loops + , any (`Set.member` textual_deps) loop + , this_build_mod `notElem` loop ] + + + let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps] + + -- All of the module's home-module dependencies. + let home_deps_with_idx = + [ home_dep | dep <- Set.toList all_deps + , Just home_dep <- [Map.lookup dep home_mod_map] ] + + -- Sort the list of dependencies in reverse-topological order. This way, by + -- the time we get woken up by the result of an earlier dependency, + -- subsequent dependencies are more likely to have finished. This step + -- effectively reduces the number of MVars that each thread blocks on. + let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx + + -- Wait for the all the module's dependencies to finish building. + deps_ok <- allM (fmap succeeded . readMVar) home_deps + + -- We can't build this module if any of its dependencies failed to build. + if not deps_ok + then return Failed + else do + -- Any hsc_env at this point is OK to use since we only really require + -- that the HPT contains the HMIs of our dependencies. + hsc_env <- readMVar hsc_env_var + old_hpt <- readIORef old_hpt_var + + let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) + + -- Limit the number of parallel compiles. + let withSem sem = bracket_ (waitQSem sem) (signalQSem sem) + mb_mod_info <- withSem par_sem $ + handleSourceError (\err -> do logger err; return Nothing) $ do + -- Have the ModSummary and HscEnv point to our local log_action + -- and filesToClean var. + let lcl_mod = localize_mod mod + let lcl_hsc_env = localize_hsc_env hsc_env + + -- Re-typecheck the loop + -- This is necessary to make sure the knot is tied when + -- we close a recursive module loop, see bug #12035. + type_env_var <- liftIO $ newIORef emptyNameEnv + let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var = + Just (ms_mod lcl_mod, type_env_var) } + lcl_hsc_env'' <- case finish_loop of + Nothing -> return lcl_hsc_env' + -- In the non-parallel case, the retypecheck prior to + -- typechecking the loop closer includes all modules + -- EXCEPT the loop closer. However, our precomputed + -- SCCs include the loop closer, so we have to filter + -- it out. + Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ + filter (/= moduleName (fst this_build_mod)) $ + map (moduleName . fst) loop + + -- Compile the module. + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods + lcl_mod mod_index num_mods + return (Just mod_info) + + case mb_mod_info of + Nothing -> return Failed + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Prune the old HPT unless this is an hs-boot module. + unless (isBootSummary mod) $ + atomicModifyIORef' old_hpt_var $ \old_hpt -> + (delFromHpt old_hpt this_mod, ()) + + -- Update and fetch the global HscEnv. + lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do + let hsc_env' = hsc_env + { hsc_HPT = addToHpt (hsc_HPT hsc_env) + this_mod mod_info } + -- We've finished typechecking the module, now we must + -- retypecheck the loop AGAIN to ensure unfoldings are + -- updated. This time, however, we include the loop + -- closer! + hsc_env'' <- case finish_loop of + Nothing -> return hsc_env' + Just loop -> typecheckLoop lcl_dflags hsc_env' $ + map (moduleName . fst) loop + return (hsc_env'', localize_hsc_env hsc_env'') + + -- Clean up any intermediate files. + cleanup lcl_hsc_env' + return Succeeded + + where + localize_mod mod + = mod { ms_hspp_opts = (ms_hspp_opts mod) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + + localize_hsc_env hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + +-- ----------------------------------------------------------------------------- +-- +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. +upsweep + :: GhcMonad m + => Maybe Messager + -> HomePackageTable -- ^ HPT from last time round (pruned) + -> StableModules -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep mHscMessage old_hpt stable_mods cleanup sccs = do + dflags <- getSessionDynFlags + (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) + (unitIdsToCheck dflags) done_holes + return (res, reverse $ mgModSummaries done) + where + done_holes = emptyUniqSet + + keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do + let sum_deps ms (AcyclicSCC mod) = + if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms + then ms_mod_name mod:ms + else ms + sum_deps ms _ = ms + dep_closure = foldl' sum_deps this_mods mods + dropped_ms = drop (length this_mods) (reverse dep_closure) + prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure + prunable _ = False + mods' = filter (not . prunable) mods + nmods' = nmods - length dropped_ms + + when (not $ null dropped_ms) $ do + dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms) + (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes + return (Failed, done') + + upsweep' + :: GhcMonad m + => HomePackageTable + -> ModuleGraph + -> [SCC ModSummary] + -> Int + -> Int + -> [UnitId] + -> UniqSet ModuleName + -> m (SuccessFlag, ModuleGraph) + upsweep' _old_hpt done + [] _ _ uids_to_check _ + = do hsc_env <- getSession + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check + return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + if gopt Opt_KeepGoing dflags + then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods + uids_to_check done_holes + else return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- TODO: Cache this, so that we don't repeatedly re-check + -- our imports when you run --make. + let (ready_uids, uids_to_check') + = partition (\uid -> isEmptyUniqDSet + (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) + uids_to_check + done_holes' + | ms_hsc_src mod == HsigFile + = addOneToUniqSet done_holes (ms_mod_name mod) + | otherwise = done_holes + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + -- Get ready to tie the knot + type_env_var <- liftIO $ newIORef emptyNameEnv + let hsc_env1 = hsc_env { hsc_type_env_var = + Just (ms_mod mod, type_env_var) } + setSession hsc_env1 + + -- Lazily reload the HPT modules participating in the loop. + -- See Note [Tying the knot]--if we don't throw out the old HPT + -- and reinitalize the knot-tying process, anything that was forced + -- while we were previously typechecking won't get updated, this + -- was bug #12035. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done + setSession hsc_env2 + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> do + dflags <- getSessionDynFlags + if gopt Opt_KeepGoing dflags + then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods + uids_to_check done_holes + else return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info + hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probably for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromHpt old_hpt this_mod + + done' = extendMG done mod + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. We have to do this again + -- to make sure we have the final unfoldings, which may + -- not have been computed accurately in the previous + -- retypecheck. + hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' + setSession hsc_env4 + + -- Add any necessary entries to the static pointer + -- table. See Note [Grand plan for static forms] in + -- StaticPtrTable. + when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ + liftIO $ hscAddSptEntries hsc_env4 + [ spt + | Just linkable <- pure $ hm_linkable mod_info + , unlinked <- linkableUnlinked linkable + , BCOs _ spts <- pure unlinked + , spt <- spts + ] + + upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' + +unitIdsToCheck :: DynFlags -> [UnitId] +unitIdsToCheck dflags = + nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) + where + goUnitId uid = + case splitUnitIdInsts uid of + (_, Just indef) -> + let insts = indefUnitIdInsts indef + in uid : concatMap (goUnitId . moduleUnitId . snd) insts + _ -> [] + +maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) +maybeGetIfaceDate dflags location + | writeInterfaceOnlyMode dflags + -- Minor optimization: it should be harmless to check the hi file location + -- always, but it's better to avoid hitting the filesystem if possible. + = modificationTimeIfExists (ml_hi_file location) + | otherwise + = return Nothing + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> Maybe Messager + -> HomePackageTable + -> StableModules + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo +upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj + is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco + + old_hmi = lookupHpt old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fllvm to -fasm and vice-versa, or away from -fno-code, + -- otherwise we could end up trying to link object code to byte + -- code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + && not (prevailing_target == HscNothing) + && not (prevailing_target == HscInterpreted) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo + compile_it mb_linkable src_modified = + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods + mb_old_iface mb_linkable src_modified + + compile_it_discard_iface :: Maybe Linkable -> SourceModified + -> IO HomeModInfo + compile_it_discard_iface mb_linkable src_modified = + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods + Nothing mb_linkable src_modified + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) SourceUnmodifiedAndStable + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) SourceUnmodified + + -- See Note [Recompilation checking in -fno-code mode] + | writeInterfaceOnlyMode dflags, + Just if_date <- mb_if_date, + if_date >= hs_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping tc'd mod:" <+> ppr this_mod_name) + compile_it Nothing SourceUnmodified + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing SourceModified + + +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +hscTarget == HscNothing. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, -fwrite-interface would be discarded and it would be +considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using template haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses template haskell, to generate object +code. + +The flavour of generated object code is chosen by defaultObjectTarget for the +target platform. It would likely be faster to generate bytecode, but this is not +supported on all platforms(?Please Confirm?), and does not support the entirety +of GHC haskell. See #1257. + +The object files (and interface files if -fwrite-interface is disabled) produced +for template haskell are written to temporary files. + +Note that since template haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o. Fix it. +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + +-- Note [Recompilation checking in -fno-code mode] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we are compiling with -fno-code -fwrite-interface, there won't +-- be any object code that we can compare against, nor should there +-- be: we're *just* generating interface files. In this case, we +-- want to check if the interface file is new, in lieu of the object +-- file. See also #9243. + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToHpt [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupHpt hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function GHC.IfaceToCore.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | Just loop <- getModLoop ms mss appearsAsBoot + -- SOME hs-boot files should still + -- get used, just not the loop-closer. + , let non_boot = filter (\l -> not (isBootSummary l && + ms_mod l == ms_mod ms)) loop + = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + mss = mgModSummaries graph + appearsAsBoot = (`elemModuleSet` mgBootModules graph) + +-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a +-- corresponding boot file in @graph@, return the set of modules which +-- transitively depend on this boot file. This function is slightly misnamed, +-- but its name "getModLoop" alludes to the fact that, when getModLoop is called +-- with a graph that does not contain @ms@ (non-parallel case) or is an +-- SCC with hs-boot nodes dropped (parallel-case), the modules which +-- depend on the hs-boot file are typically (but not always) the +-- modules participating in the recursive module loop. The returned +-- list includes the hs-boot file. +-- +-- Example: +-- let g represent the module graph: +-- C.hs +-- A.hs-boot imports C.hs +-- B.hs imports A.hs-boot +-- A.hs imports B.hs +-- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs] +-- +-- It would also be permissible to omit A.hs from the graph, +-- in which case the result is [A.hs-boot, B.hs] +-- +-- Example: +-- A counter-example to the claim that modules returned +-- by this function participate in the loop occurs here: +-- +-- let g represent the module graph: +-- C.hs +-- A.hs-boot imports C.hs +-- B.hs imports A.hs-boot +-- A.hs imports B.hs +-- D.hs imports A.hs-boot +-- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs] +-- +-- Arguably, D.hs should import A.hs, not A.hs-boot, but +-- a dependency on the boot file is not illegal. +-- +getModLoop + :: ModSummary + -> [ModSummary] + -> (Module -> Bool) -- check if a module appears as a boot module in 'graph' + -> Maybe [ModSummary] +getModLoop ms graph appearsAsBoot + | not (isBootSummary ms) + , appearsAsBoot this_mod + , let mss = reachableBackwards (ms_mod_name ms) graph + = Just mss + | otherwise + = Nothing + where + this_mod = ms_mod ms + +-- NB: sometimes mods has duplicates; this is harmless because +-- any duplicates get clobbered in addListToHpt and never get forced. +typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop dflags hsc_env mods = do + debugTraceMsg dflags 2 $ + text "Re-typechecking loop: " <> ppr mods + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToHpt old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ node_payload node | node <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- +-- | Topological sort of the module graph +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> ModuleGraph + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + summaries = mgModSummaries module_graph + -- stronglyConnCompG flips the original order, so if we reverse + -- the summaries we get a stable topological sort. + (graph, lookup_node) = + moduleGraphNodes drop_hs_boot_nodes (reverse summaries) + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod + , graph `hasVertexG` node + = node + | otherwise + = throwGhcException (ProgramError "module does not exist") + in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) + +type SummaryNode = Node Int ModSummary + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey = node_key + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary = node_payload + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), + hscSourceToIsBoot (ms_hsc_src s)), node) + | node <- nodes + , let s = summaryNodeSummary node ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ DigraphNode s key out_keys + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else NotBoot + +-- The nodes of the graph are keyed by (mod, is boot?) pairs +-- NB: hsig files show up as *normal* nodes (not boot!), since they don't +-- participate in cycles (for now) +type NodeKey = (ModuleName, IsBoot) +type NodeMap a = Map.Map NodeKey a + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) + = (moduleName mod, hscSourceToIsBoot boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + dflags <- getDynFlags + when (wopt Opt_WarnUnusedImports dflags) + (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) + where check dflags ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainErrMsg dflags loc + (text "Warning: {-# SOURCE #-} unnecessary in import of " + <+> quotes (ppr mod)) + + +----------------------------------------------------------------------------- +-- +-- | Downsweep (dependency analysis) +-- +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. +-- +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [Either ErrorMessages ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 + root_map = mkRootMap rootSummariesOk + checkDuplicates root_map + map0 <- loop (concatMap calcDeps rootSummariesOk) root_map + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + map1 <- if hscTarget dflags == HscNothing + then enableCodeGenForTH + (defaultObjectTarget dflags) + map0 + else if hscTarget dflags == HscInterpreted + then enableCodeGenForUnboxedTuplesOrSums + (defaultObjectTarget dflags) + map0 + else return map0 + if null errs + then pure $ concat $ nodeMapElts map1 + else pure $ map Left errs + where + calcDeps = msDeps + + dflags = hsc_dflags hsc_env + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO (Either ErrorMessages ModSummary) + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists || isJust maybe_buf + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> return $ Left $ moduleNotFoundErr dflags modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "<command line>") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map + + loop :: [(Located ModuleName,IsBoot)] + -- Work list: process these modules + -> NodeMap [Either ErrorMessages ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO (NodeMap [Either ErrorMessages ModSummary]) + -- The result is the completed NodeMap + loop [] done = return done + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr dflags (rights summs); return Map.empty } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just (Left e) -> loop ss (Map.insert key [Left e] done) + Just (Right s)-> do + new_map <- + loop (calcDeps s) (Map.insert key [Right s] done) + loop ss new_map + where + key = (unLoc wanted_mod, is_boot) + +-- | Update the every ModSummary that is depended on +-- by a module that needs template haskell. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- See Note [-fno-code mode] +enableCodeGenForTH :: HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenForTH = + enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession + where + condition = isTemplateHaskellOrQQNonBoot + should_modify (ModSummary { ms_hspp_opts = dflags }) = + hscTarget dflags == HscNothing && + -- Don't enable codegen for TH on indefinite packages; we + -- can't compile anything anyway! See #16219. + not (isIndefinite dflags) + +-- | Update the every ModSummary that is depended on +-- by a module that needs unboxed tuples. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- +-- This is used used in order to load code that uses unboxed tuples +-- or sums into GHCi while still allowing some code to be interpreted. +enableCodeGenForUnboxedTuplesOrSums :: HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenForUnboxedTuplesOrSums = + enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule + where + condition ms = + unboxed_tuples_or_sums (ms_hspp_opts ms) && + not (gopt Opt_ByteCode (ms_hspp_opts ms)) && + not (isBootSummary ms) + unboxed_tuples_or_sums d = + xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d + should_modify (ModSummary { ms_hspp_opts = dflags }) = + hscTarget dflags == HscInterpreted + +-- | Helper used to implement 'enableCodeGenForTH' and +-- 'enableCodeGenForUnboxedTuples'. In particular, this enables +-- unoptimized code generation for all modules that meet some +-- condition (first parameter), or are dependencies of those +-- modules. The second parameter is a condition to check before +-- marking modules for code generation. +enableCodeGenWhen + :: (ModSummary -> Bool) + -> (ModSummary -> Bool) + -> TempFileLifetime + -> TempFileLifetime + -> HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenWhen condition should_modify staticLife dynLife target nodemap = + traverse (traverse (traverse enable_code_gen)) nodemap + where + enable_code_gen ms + | ModSummary + { ms_mod = ms_mod + , ms_location = ms_location + , ms_hsc_src = HsSrcFile + , ms_hspp_opts = dflags + } <- ms + , should_modify ms + , ms_mod `Set.member` needs_codegen_set + = do + let new_temp_file suf dynsuf = do + tn <- newTempName dflags staticLife suf + let dyn_tn = tn -<.> dynsuf + addFilesToClean dflags dynLife [dyn_tn] + return tn + -- We don't want to create .o or .hi files unless we have been asked + -- to by the user. But we need them, so we patch their locations in + -- the ModSummary with temporary files. + -- + (hi_file, o_file) <- + -- If ``-fwrite-interface` is specified, then the .o and .hi files + -- are written into `-odir` and `-hidir` respectively. #16670 + if gopt Opt_WriteInterface dflags + then return (ml_hi_file ms_location, ml_obj_file ms_location) + else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags)) + <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags)) + return $ + ms + { ms_location = + ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} + , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target} + } + | otherwise = return ms + + needs_codegen_set = transitive_deps_set + [ ms + | mss <- Map.elems nodemap + , Right ms <- mss + , condition ms + ] + + -- find the set of all transitive dependencies of a list of modules. + transitive_deps_set modSums = foldl' go Set.empty modSums + where + go marked_mods ms@ModSummary{ms_mod} + | ms_mod `Set.member` marked_mods = marked_mods + | otherwise = + let deps = + [ dep_ms + -- If a module imports a boot module, msDeps helpfully adds a + -- dependency to that non-boot module in it's result. This + -- means we don't have to think about boot modules here. + | (L _ mn, NotBoot) <- msDeps ms + , dep_ms <- + toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>= + toList + ] + new_marked_mods = Set.insert ms_mod marked_mods + in foldl' go new_marked_mods deps + +mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [Right s]) | s <- summaries ] + Map.empty + +-- | Returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps :: ModSummary -> [(Located ModuleName, IsBoot)] +msDeps s = + concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] + ++ [ (m,NotBoot) | m <- ms_home_imps s ] + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,UTCTime) + -> IO (Either ErrorMessages ModSummary) + +summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries src_fn + = do + let location = ms_location old_summary + dflags = hsc_dflags hsc_env + + src_timestamp <- get_src_timestamp + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + checkSummaryTimestamp + hsc_env dflags obj_allowed NotBoot (new_summary src_fn) + old_summary location src_timestamp + + | otherwise + = do src_timestamp <- get_src_timestamp + new_summary src_fn src_timestamp + where + get_src_timestamp = case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime src_fn + -- getModificationUTCTime may fail + + new_summary src_fn src_timestamp = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf + + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = NotBoot + , nms_hsc_src = + if isHaskellSigFilename src_fn + then HsigFile + else HsSrcFile + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +checkSummaryTimestamp + :: HscEnv -> DynFlags -> Bool -> IsBoot + -> (UTCTime -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> UTCTime + -> IO (Either e ModSummary) +checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot new_summary + old_summary location src_timestamp + | ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location is_boot + else return Nothing + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular search path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + _ <- addHomeModuleToFinder hsc_env + (moduleName (ms_mod old_summary)) location + + hi_timestamp <- maybeGetIfaceDate dflags location + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + + | otherwise = + -- source changed: re-summarise. + new_summary src_timestamp + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> + Just <$> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationUTCTime src_fn) + case m of + Right t -> + Just <$> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + check_timestamp old_summary location src_fn = + checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot + (new_summary location (ms_mod old_summary) src_fn) + old_summary location + + find_it = do + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + Just <$> just_found location mod + + _ -> return Nothing + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | IsBoot <- is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> return $ Left $ noHsFileErr dflags loc src_fn + Just t -> new_summary location' mod src_fn t + + new_summary location mod src_fn src_timestamp + = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src = case is_boot of + IsBoot -> HsBootFile + _ | isHaskellSigFilename src_fn -> HsigFile + | otherwise -> HsSrcFile + + when (pi_mod_name /= wanted_mod) $ + throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr pi_mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $ + let suggested_instantiated_with = + hcat (punctuate comma $ + [ ppr k <> text "=" <> ppr v + | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) + : thisUnitIdInsts dflags) + ]) + in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "Unexpected signature:" <+> quotes (ppr pi_mod_name) + $$ if gopt Opt_BuildingCabalPackage dflags + then parens (text "Try adding" <+> quotes (ppr pi_mod_name) + <+> text "to the" + <+> quotes (text "signatures") + <+> text "field in your Cabal file.") + else parens (text "Try passing -instantiated-with=\"" <> + suggested_instantiated_with <> text "\"" $$ + text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = is_boot + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_timestamp :: UTCTime + , nms_is_boot :: IsBoot + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_obj_allowed :: Bool + , nms_preimps :: PreprocessedImports + } + +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + let dflags = hsc_dflags hsc_env + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget dflags) + || nms_obj_allowed -- bug #1205 + then getObjTimestamp nms_location nms_is_boot + else return Nothing + + hi_timestamp <- maybeGetIfaceDate dflags nms_location + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + required_by_imports <- implicitRequirements hsc_env pi_theimps + + return $ ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + pi_theimps ++ extra_sig_imports ++ required_by_imports + , ms_hs_date = nms_src_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + } + +getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) +getObjTimestamp location is_boot + = if is_boot == IsBoot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [(Maybe FastString, Located ModuleName)] + , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } + +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT ErrorMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) + <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn + return PreprocessedImports {..} + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +-- Defer and group warning, error and fatal messages so they will not get lost +-- in the regular output. +withDeferredDiagnostics :: GhcMonad m => m a -> m a +withDeferredDiagnostics f = do + dflags <- getDynFlags + if not $ gopt Opt_DeferDiagnostics dflags + then f + else do + warnings <- liftIO $ newIORef [] + errors <- liftIO $ newIORef [] + fatals <- liftIO $ newIORef [] + + let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do + let action = putLogMsg dflags reason severity srcSpan style msg + case severity of + SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) + SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) + SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) + _ -> action + + printDeferredDiagnostics = liftIO $ + forM_ [warnings, errors, fatals] $ \ref -> do + -- This IORef can leak when the dflags leaks, so let us always + -- reset the content. + actions <- atomicModifyIORef' ref $ \i -> ([], i) + sequence_ $ reverse actions + + setLogAction action = modifySession $ \hsc_env -> + hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } + + gbracket + (setLogAction deferDiagnostics) + (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) + (\_ -> f) + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages +noHsFileErr dflags loc path + = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path + +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages +moduleNotFoundErr dflags mod + = unitBag $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" + +multiRootsErr :: DynFlags -> [ModSummary] -> IO () +multiRootsErr _ [] = panic "multiRootsErr" +multiRootsErr dflags summs@(summ1:_) + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +keepGoingPruneErr :: [ModuleName] -> SDoc +keepGoingPruneErr ms + = vcat (( text "-fkeep-going in use, removing the following" <+> + text "dependencies and continuing:"): + map (nest 6 . ppr) ms ) + +cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> text "Unexpected non-cycle" <+> ppr mss + Just path -> vcat [ text "Module imports form a cycle:" + , nest 2 (show_path path) ] + where + graph :: [Node NodeKey ModSummary] + graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) + + show_path [] = panic "show_path" + show_path [m] = text "module" <+> ppr_ms m + <+> text "imports itself" + show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1) + : nest 6 (text "imports" <+> ppr_ms m2) + : go ms ) + where + go [] = [text "which imports" <+> ppr_ms m1] + go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms + + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs new file mode 100644 index 0000000000..d1d3b00394 --- /dev/null +++ b/compiler/GHC/Driver/MakeFile.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Makefile Dependency Generation +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.MakeFile + ( doMkDependHS + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import qualified GHC +import GHC.Driver.Monad +import GHC.Driver.Session +import Util +import GHC.Driver.Types +import qualified SysTools +import Module +import Digraph ( SCC(..) ) +import GHC.Driver.Finder +import Outputable +import Panic +import SrcLoc +import Data.List +import FastString +import FileCleanup + +import Exception +import ErrUtils + +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error ( isEOFError ) +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Data.IORef + +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: GhcMonad m => [FilePath] -> m () +doMkDependHS srcs = do + -- Initialisation + dflags0 <- GHC.getSessionDynFlags + + -- We kludge things a bit for dependency generation. Rather than + -- generating dependencies for each way separately, we generate + -- them once and then duplicate them for each way's osuf/hisuf. + -- We therefore do the initial dependency generation with an empty + -- way and .o/.hi extensions, regardless of any flags that might + -- be specified. + let dflags = dflags0 { + ways = [], + buildTag = mkBuildTag [], + hiSuf = "hi", + objectSuf = "o" + } + _ <- GHC.setSessionDynFlags dflags + + when (null (depSuffixes dflags)) $ liftIO $ + throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") + + files <- liftIO $ beginMkDependHS dflags + + -- Do the downsweep to find all the modules + targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs + GHC.setTargets targets + let excl_mods = depExcludeMods dflags + module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} + + -- Sort into dependency order + -- There should be no cycles + let sorted = GHC.topSortModuleGraph False module_graph Nothing + + -- Print out the dependencies if wanted + liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + + -- Process them one by one, dumping results into makefile + -- and complaining about cycles + hsc_env <- getSession + root <- liftIO getCurrentDirectory + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles dflags module_graph + + -- Tidy up + liftIO $ endMkDependHS dflags files + + -- Unconditional exiting is a bad idea. If an error occurs we'll get an + --exception; if that is not caught it's fine, but at least we have a + --chance to find out exactly what went wrong. Uncomment the following + --line if you disagree. + + --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: DynFlags -> IO MkDepFiles +beginMkDependHS dflags = do + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName dflags TFL_CurrentModule "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + let makefile = depMakefile dflags + exists <- doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + catchIO chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> HscEnv + -> [ModuleName] + -> FilePath + -> Handle -- Write dependencies to here + -> SCC ModSummary + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps dflags _ _ _ _ (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) + +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) + = do { let extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp loc is_boot pkg_qual imp_mod + = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod + is_boot include_pkg_deps + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency root hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency root hdl obj_files src_file + + -- Emit a dependency for each CPP import + ; when (depIncludeCppDeps dflags) $ do + -- CPP deps are descovered in the module parsing phase by parsing + -- comment lines left by the preprocessor. + -- Note that GHC.parseModule may throw an exception if the module + -- fails to parse, which may not be desirable (see #16616). + { session <- Session <$> newIORef hsc_env + ; parsedMod <- reflectGhc (GHC.parseModule node) session + ; mapM_ (writeDependency root hdl obj_files) + (GHC.pm_extra_src_files parsedMod) + } + + -- Emit a dependency for each import + + ; let do_imps is_boot idecls = sequence_ + [ do_imp loc is_boot mb_pkg mod + | (mb_pkg, L loc mod) <- idecls, + mod `notElem` excl_mods ] + + ; do_imps True (ms_srcimps node) + ; do_imps False (ms_imps node) + } + + +findDependency :: HscEnv + -> SrcSpan + -> Maybe FastString -- package qualifier, if any + -> ModuleName -- Imported module + -> IsBootInterface -- Source import + -> Bool -- Record dependency on package modules + -> IO (Maybe FilePath) -- Interface file file +findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps + = do { -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findImportedModule hsc_env imp pkg + ; case r of + Found loc _ + -- Home package: just depend on the .hi or hi-boot file + | isJust (ml_hs_file loc) || include_pkg_deps + -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + + fail -> + let dflags = hsc_dflags hsc_env + in throwOneError $ mkPlainErrMsg dflags srcloc $ + cannotFindModule dflags imp fail + } + +----------------------------- +writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency root hdl targets dep + = do let -- We need to avoid making deps on + -- c:/foo/... + -- on cygwin as make gets confused by the : + -- Making relative deps avoids some instances of this. + dep' = makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . normalise + output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' + hPutStrLn hdl output + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Suffix prefixes e.g. ["x_", "y_"] + -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + -- Note that that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we know where to + -- split it +insertSuffixes file_name extras + = [ basename <.> (extra ++ suffix) | extra <- extras ] + where + (basename, suffix) = case splitExtension file_name of + -- Drop the "." from the extension + (b, s) -> (b, drop 1 s) + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- + +endMkDependHS :: DynFlags -> MkDepFiles -> IO () + +endMkDependHS dflags + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + + -- slurp the rest of the original makefile and copy it into the output + let slurp = do + l <- hGetLine hdl + hPutStrLn tmp_hdl l + slurp + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- Create a backup of the original makefile + when (isJust makefile_hdl) + (SysTools.copy dflags ("Backing up " ++ makefile) + makefile (makefile++".bak")) + + -- Copy the new makefile in place + SysTools.copy dflags "Installing new makefile" tmp_file makefile + + +----------------------------------------------------------------- +-- Module cycles +----------------------------------------------------------------- + +dumpModCycles :: DynFlags -> ModuleGraph -> IO () +dumpModCycles dflags module_graph + | not (dopt Opt_D_dump_mod_cycles dflags) + = return () + + | null cycles + = putMsg dflags (text "No module cycles") + + | otherwise + = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) + where + + cycles :: [[ModSummary]] + cycles = + [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ] + + pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) + $$ pprCycle c $$ blankLine + | (n,c) <- [1..] `zip` cycles ] + +pprCycle :: [ModSummary] -> SDoc +-- Print a cycle, but show only the imports within the cycle +pprCycle summaries = pp_group (CyclicSCC summaries) + where + cycle_mods :: [ModuleName] -- The modules in this cycle + cycle_mods = map (moduleName . ms_mod) summaries + + pp_group (AcyclicSCC ms) = pp_ms ms + pp_group (CyclicSCC mss) + = ASSERT( not (null boot_only) ) + -- The boot-only list must be non-empty, else there would + -- be an infinite chain of non-boot imports, and we've + -- already checked for that in processModDeps + pp_ms loop_breaker $$ vcat (map pp_group groups) + where + (boot_only, others) = partition is_boot_only mss + is_boot_only ms = not (any in_group (map snd (ms_imps ms))) + in_group (L _ m) = m `elem` group_mods + group_mods = map (moduleName . ms_mod) mss + + loop_breaker = head boot_only + all_others = tail boot_only ++ others + groups = + GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing + + pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) + <+> (pp_imps empty (map snd (ms_imps summary)) $$ + pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) + where + mod_str = moduleNameString (moduleName (ms_mod summary)) + + pp_imps :: SDoc -> [Located ModuleName] -> SDoc + pp_imps _ [] = empty + pp_imps what lms + = case [m | L _ m <- lms, m `elem` cycle_mods] of + [] -> empty + ms -> what <+> text "imports" <+> + pprWithCommas ppr ms + +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + +depStartMarker, depEndMarker :: String +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" + diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs new file mode 100644 index 0000000000..3825757ac6 --- /dev/null +++ b/compiler/GHC/Driver/Monad.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GHC.Driver.Monad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings, printException, + WarnErrLogger, defaultWarnErrLogger + ) where + +import GhcPrelude + +import MonadUtils +import GHC.Driver.Types +import GHC.Driver.Session +import Exception +import ErrUtils + +import Control.Monad +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `gfinally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor) + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Applicative Ghc where + pure a = Ghc $ \_ -> return a + g <*> m = do f <- g; a <- m; return (f a) + +instance Monad Ghc where + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance MonadFix Ghc where + mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) + +instance ExceptionMonad Ghc where + gcatch act handle = + Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s + gmask f = + Ghc $ \s -> gmask $ \io_restore -> + let + g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) + in + unGhc (f g_restore) s + +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } + deriving (Functor) + +liftGhcT :: m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + +instance Monad m => Monad (GhcT m) where + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance ExceptionMonad m => ExceptionMonad (GhcT m) where + gcatch act handle = + GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s + gmask f = + GhcT $ \s -> gmask $ \io_restore -> + let + g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) + in + unGhcT (f g_restore) s + +instance MonadIO m => HasDynFlags (GhcT m) where + getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) + +instance ExceptionMonad m => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +-- | A function called to log warnings and errors. +type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e + diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs new file mode 100644 index 0000000000..572da5f3d1 --- /dev/null +++ b/compiler/GHC/Driver/Packages.hs @@ -0,0 +1,2215 @@ +-- (c) The University of Glasgow, 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} + +-- | Package manipulation +module GHC.Driver.Packages ( + module UnitInfo, + + -- * Reading the package config, and processing cmdline args + PackageState(preloadPackages, explicitPackages, moduleNameProvidersMap, requirementContext), + PackageDatabase (..), + UnitInfoMap, + emptyPackageState, + initPackages, + readPackageDatabases, + readPackageDatabase, + getPackageConfRefs, + resolvePackageDatabase, + listUnitInfoMap, + + -- * Querying the package config + lookupUnit, + lookupUnit', + lookupInstalledPackage, + lookupPackageName, + improveUnitId, + searchPackageId, + getPackageDetails, + getInstalledPackageDetails, + componentIdString, + displayInstalledUnitId, + listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + lookupPluginModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), + UnusablePackageReason(..), + pprReason, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getUnitInfoMap, + getPreloadPackagesAnd, + + collectArchives, + collectIncludeDirs, collectLibraryPaths, collectLinkOpts, + packageHsLibs, getLibs, + + -- * Utils + unwireUnitId, + pprFlag, + pprPackages, + pprPackagesSimple, + pprModuleMap, + isIndefinite, + isDllName + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.PackageDb +import UnitInfo +import GHC.Driver.Session +import Name ( Name, nameModule_maybe ) +import UniqFM +import UniqDFM +import UniqSet +import Module +import Util +import Panic +import GHC.Platform +import Outputable +import Maybes + +import System.Environment ( getEnv ) +import FastString +import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, + withTiming, DumpFormat (..) ) +import Exception + +import System.Directory +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import Control.Monad +import Data.Graph (stronglyConnComp, SCC(..)) +import Data.Char ( toUpper ) +import Data.List as List +import Data.Map (Map) +import Data.Set (Set) +import Data.Monoid (First(..)) +import qualified Data.Semigroup as Semigroup +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import qualified Data.Set as Set +import Data.Version + +-- --------------------------------------------------------------------------- +-- The Package state + +-- | Package state is all stored in 'DynFlags', including the details of +-- all packages, which packages are exposed, and which modules they +-- provide. +-- +-- The package state is computed by 'initPackages', and kept in DynFlags. +-- It is influenced by various package flags: +-- +-- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. +-- +-- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. +-- +-- * (there are a few more flags, check below for their semantics) +-- +-- The package state has the following properties. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. +-- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of +-- their dependencies. +-- +-- * When searching for a module from a preload import declaration, +-- only the exposed modules in @exposedPackages@ are valid. +-- +-- * When searching for a module from an implicit import, all modules +-- from @depExposedPackages@ are valid. +-- +-- * When linking in a compilation manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with preload @-package@ flags on the command-line, +-- or are a transitive dependency of same, or are \"base\"\/\"rts\". +-- The reason for this is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is unavailable because the package is unusable. + | ModUnusable UnusablePackageReason + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + _x <> _y = panic "ModOrigin: hidden module redefined" + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +-- | 'UniqFM' map from 'InstalledUnitId' +type InstalledUnitIdMap = UniqDFM + +-- | 'UniqFM' map from 'UnitId' to 'UnitInfo', plus +-- the transitive closure of preload packages. +data UnitInfoMap = UnitInfoMap { + unUnitInfoMap :: InstalledUnitIdMap UnitInfo, + -- | The set of transitively reachable packages according + -- to the explicitly provided command line arguments. + -- See Note [UnitId to InstalledUnitId improvement] + preloadClosure :: UniqSet InstalledUnitId + } + +-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. +type VisibilityMap = Map UnitId UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'UnitId'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name is associated with the 'UnitId'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: Map ModuleName (Set IndefModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Bool + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_explicit = uv_explicit uv1 || uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = Map.empty + , uv_explicit = False + } + mappend = (Semigroup.<>) + +type WiredUnitId = DefUnitId +type PreloadUnitId = InstalledUnitId + +-- | Map from 'ModuleName' to a set of of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' +type ModuleNameProvidersMap = + Map ModuleName (Map Module ModuleOrigin) + +data PackageState = PackageState { + -- | A mapping of 'UnitId' to 'UnitInfo'. This list is adjusted + -- so that only valid packages are here. 'UnitInfo' reflects + -- what was stored *on disk*, except for the 'trusted' flag, which + -- is adjusted at runtime. (In particular, some packages in this map + -- may have the 'exposed' flag be 'False'.) + unitInfoMap :: UnitInfoMap, + + -- | A mapping of 'PackageName' to 'ComponentId'. This is used when + -- users refer to packages in Backpack includes. + packageNameMap :: Map PackageName ComponentId, + + -- | A mapping from wired in names to the original names from the + -- package database. + unwireMap :: Map WiredUnitId WiredUnitId, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + preloadPackages :: [PreloadUnitId], + + -- | Packages which we explicitly depend on (from a command line flag). + -- We'll use this to generate version macros. + explicitPackages :: [UnitId], + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility. + pluginModuleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map saying, for each requirement, what interfaces must be merged + -- together when we use them. For example, if our dependencies + -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces + -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@ + -- and @r[C=<A>]:C@. + -- + -- There's an entry in this map for each hole in our home library. + requirementContext :: Map ModuleName [IndefModule] + } + +emptyPackageState :: PackageState +emptyPackageState = PackageState { + unitInfoMap = emptyUnitInfoMap, + packageNameMap = Map.empty, + unwireMap = Map.empty, + preloadPackages = [], + explicitPackages = [], + moduleNameProvidersMap = Map.empty, + pluginModuleNameProvidersMap = Map.empty, + requirementContext = Map.empty + } + +-- | Package database +data PackageDatabase = PackageDatabase + { packageDatabasePath :: FilePath + , packageDatabaseUnits :: [UnitInfo] + } + +type InstalledPackageIndex = Map InstalledUnitId UnitInfo + +-- | Empty package configuration map +emptyUnitInfoMap :: UnitInfoMap +emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet + +-- | Find the unit we know about with the given unit id, if any +lookupUnit :: DynFlags -> UnitId -> Maybe UnitInfo +lookupUnit dflags = lookupUnit' (isIndefinite dflags) (unitInfoMap (pkgState dflags)) + +-- | A more specialized interface, which takes a boolean specifying +-- whether or not to look for on-the-fly renamed interfaces, and +-- just a 'UnitInfoMap' rather than a 'DynFlags' (so it can +-- be used while we're initializing 'DynFlags' +lookupUnit' :: Bool -> UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnit' False (UnitInfoMap pkg_map _) uid = lookupUDFM pkg_map uid +lookupUnit' True m@(UnitInfoMap pkg_map _) uid = + case splitUnitIdInsts uid of + (iuid, Just indef) -> + fmap (renamePackage m (indefUnitIdInsts indef)) + (lookupUDFM pkg_map iuid) + (_, Nothing) -> lookupUDFM pkg_map uid + +{- +-- | Find the indefinite package for a given 'ComponentId'. +-- The way this works is just by fiat'ing that every indefinite package's +-- unit key is precisely its component ID; and that they share uniques. +lookupComponentId :: DynFlags -> ComponentId -> Maybe UnitInfo +lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs + where + UnitInfoMap pkg_map = unitInfoMap (pkgState dflags) +-} + +-- | Find the package we know about with the given package name (e.g. @foo@), if any +-- (NB: there might be a locally defined unit name which overrides this) +lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId +lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> SourcePackageId -> [UnitInfo] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listUnitInfoMap dflags) + +-- | Extends the package configuration map with a list of package configs. +extendUnitInfoMap + :: UnitInfoMap -> [UnitInfo] -> UnitInfoMap +extendUnitInfoMap (UnitInfoMap pkg_map closure) new_pkgs + = UnitInfoMap (foldl' add pkg_map new_pkgs) closure + -- We also add the expanded version of the packageConfigId, so that + -- 'improveUnitId' can find it. + where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedUnitInfoId p) p) + (installedUnitInfoId p) p + +-- | Looks up the package with the given id in the package state, panicing if it is +-- not found +getPackageDetails :: HasDebugCallStack => DynFlags -> UnitId -> UnitInfo +getPackageDetails dflags pid = + case lookupUnit dflags pid of + Just config -> config + Nothing -> pprPanic "getPackageDetails" (ppr pid) + +lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage dflags uid = lookupInstalledPackage' (unitInfoMap (pkgState dflags)) uid + +lookupInstalledPackage' :: UnitInfoMap -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid + +getInstalledPackageDetails :: HasDebugCallStack => DynFlags -> InstalledUnitId -> UnitInfo +getInstalledPackageDetails dflags uid = + case lookupInstalledPackage dflags uid of + Just config -> config + Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid) + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, although all packages in this map are "visible", this +-- does not imply that the exposed-modules of the package are available +-- (they may have been thinned or renamed). +listUnitInfoMap :: DynFlags -> [UnitInfo] +listUnitInfoMap dflags = eltsUDFM pkg_map + where + UnitInfoMap pkg_map _ = unitInfoMap (pkgState dflags) + +-- ---------------------------------------------------------------------------- +-- Loading the package db files and building up the package state + +-- | Read the package database files, and sets up various internal tables of +-- package information, according to the package-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +-- +-- Returns a list of packages to link in if we're doing dynamic linking. +-- This list contains the packages that the user explicitly mentioned with +-- @-package@ flags. +-- +-- 'initPackages' can be called again subsequently after updating the +-- 'packageFlags' field of the 'DynFlags', and it will update the +-- 'pkgState' in 'DynFlags' and return a list of packages to +-- link in. +initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) +initPackages dflags = withTiming dflags + (text "initializing package database") + forcePkgDb $ do + read_pkg_dbs <- + case pkgDatabase dflags of + Nothing -> readPackageDatabases dflags + Just dbs -> return dbs + + let + distrust_all db = db { packageDatabaseUnits = distrustAllUnits (packageDatabaseUnits db) } + + pkg_dbs + | gopt Opt_DistrustAllPackages dflags = map distrust_all read_pkg_dbs + | otherwise = read_pkg_dbs + + (pkg_state, preload, insts) + <- mkPackageState dflags pkg_dbs [] + return (dflags{ pkgDatabase = Just read_pkg_dbs, + pkgState = pkg_state, + thisUnitIdInsts_ = insts }, + preload) + where + forcePkgDb (dflags, _) = unitInfoMap (pkgState dflags) `seq` () + +-- ----------------------------------------------------------------------------- +-- Reading the package database(s) + +readPackageDatabases :: DynFlags -> IO [PackageDatabase] +readPackageDatabases dflags = do + conf_refs <- getPackageConfRefs dflags + confs <- liftM catMaybes $ mapM (resolvePackageDatabase dflags) conf_refs + mapM (readPackageDatabase dflags) confs + + +getPackageConfRefs :: DynFlags -> IO [PkgDbRef] +getPackageConfRefs dflags = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | not (null path) && isSearchPathSeparator (last path) + -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (splitSearchPath path) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolvePackageDatabase :: DynFlags -> PkgDbRef -> IO (Maybe FilePath) +resolvePackageDatabase dflags GlobalPkgDb = return $ Just (globalPackageDatabasePath dflags) +resolvePackageDatabase dflags UserPkgDb = runMaybeT $ do + dir <- versionedAppDir dflags + let pkgconf = dir </> "package.conf.d" + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return pkgconf else mzero +resolvePackageDatabase _ (PkgDbPath name) = return $ Just name + +readPackageDatabase :: DynFlags -> FilePath -> IO PackageDatabase +readPackageDatabase dflags conf_file = do + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = dropTrailingPathSeparator conf_file + top_dir = topDir dflags + pkgroot = takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot) + proto_pkg_configs + -- + return $ PackageDatabase conf_file' pkg_configs1 + where + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir </> "package.cache" + cache_exists <- doesFileExist filename + if cache_exists + then do + debugTraceMsg dflags 2 $ text "Using binary package database:" + <+> text filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg dflags 2 $ text "There is no package.cache in" + <+> text conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . isSuffixOf ".conf") + <$> getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg dflags 3 $ text "There are no .conf files in" + <+> text conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else do + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile conf_file `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file <.> "d" + direxists <- doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +distrustAllUnits :: [UnitInfo] -> [UnitInfo] +distrustAllUnits pkgs = map distrust pkgs + where + distrust pkg = pkg{ trusted = False } + +mungeUnitInfo :: FilePath -> FilePath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeDynLibFields + . mungePackagePaths top_dir pkgroot + +mungeDynLibFields :: UnitInfo -> UnitInfo +mungeDynLibFields pkg = + pkg { + libraryDynDirs = libraryDynDirs pkg + `orIfNull` libraryDirs pkg + } + where + orIfNull [] flags = flags + orIfNull flags _ = flags + +-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs +mungePackagePaths :: FilePath -> FilePath -> UnitInfo -> UnitInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + libraryDynDirs = munge_paths (libraryDynDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + haddockHTMLs = munge_urls (haddockHTMLs pkg) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use </> above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Modify our copy of the package database based on trust flags, +-- -trust and -distrust. + +applyTrustFlag + :: DynFlags + -> PackagePrecedenceIndex + -> UnusablePackages + -> [UnitInfo] + -> TrustFlag + -> IO [UnitInfo] +applyTrustFlag dflags prec_map unusable pkgs flag = + case flag of + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr dflags flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr dflags flag ps + Right (ps,qs) -> return (distrustAllUnits ps ++ qs) + +-- | A little utility to tell if the 'thisPackage' is indefinite +-- (if it is not, we should never use on-the-fly renaming.) +isIndefinite :: DynFlags -> Bool +isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) + +applyPackageFlag + :: DynFlags + -> PackagePrecedenceIndex + -> UnitInfoMap + -> UnusablePackages + -> Bool -- if False, if you expose a package, it implicitly hides + -- any previously exposed packages with the same name + -> [UnitInfo] + -> VisibilityMap -- Initially exposed + -> PackageFlag -- flag to apply + -> IO VisibilityMap -- Now exposed + +applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = + case flag of + ExposePackage _ arg (ModRenaming b rns) -> + case findPackages prec_map pkg_db arg pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (p:_) -> return vm' + where + n = fsPackageName p + + -- If a user says @-unit-id p[A=<A>]@, this imposes + -- a requirement on us: whatever our signature A is, + -- it must fulfill all of p[A=<A>]:A's requirements. + -- This method is responsible for computing what our + -- inherited requirements are. + reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid + | otherwise = Map.empty + + collectHoles uid = case splitUnitIdInsts uid of + (_, Just indef) -> + let local = [ Map.singleton + (moduleName mod) + (Set.singleton $ IndefModule indef mod_name) + | (mod_name, mod) <- indefUnitIdInsts indef + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnitId mod) + | (_, mod) <- indefUnitIdInsts indef ] + in Map.unionsWith Set.union $ local ++ recurse + -- Other types of unit identities don't have holes + (_, Nothing) -> Map.empty + + + uv = UnitVisibility + { uv_expose_all = b + , uv_renamings = rns + , uv_package_name = First (Just n) + , uv_requirements = reqs + , uv_explicit = True + } + vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared + -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` + -- (or if p-0.1 was registered in the pkgdb as exposed: True), + -- the second package flag would override the first one and you + -- would only see p-0.2 in exposed modules. This is good for + -- usability. + -- + -- However, with thinning and renaming (or Backpack), there might be + -- situations where you legitimately want to see two versions of a + -- package at the same time, and this behavior would make it + -- impossible to do so. So we decided that if you pass + -- -hide-all-packages, this should turn OFF the overriding behavior + -- where an exposed package hides all other packages with the same + -- name. This should not affect Cabal at all, which only ever + -- exposes one package at a time. + -- + -- NB: Why a variable no_hide_others? We have to apply this logic to + -- -plugin-package too, and it's more consistent if the switch in + -- behavior is based off of + -- -hide-all-packages/-hide-all-plugin-packages depending on what + -- flag is in question. + vm_cleared | no_hide_others = vm + -- NB: renamings never clear + | (_:_) <- rns = vm + | otherwise = Map.filterWithKey + (\k uv -> k == packageConfigId p + || First (Just n) /= uv_package_name uv) vm + _ -> panic "applyPackageFlag" + + HidePackage str -> + case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right ps -> return vm' + where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: PackagePrecedenceIndex + -> UnitInfoMap -> PackageArg -> [UnitInfo] + -> UnusablePackages + -> Either [(UnitInfo, UnusablePackageReason)] + [UnitInfo] +findPackages prec_map pkg_db arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (Map.elems unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if str == sourcePackageIdString p || str == packageNameString p + then Just p + else Nothing + finder (UnitIdArg uid) p + = let (iuid, mb_indef) = splitUnitIdInsts uid + in if iuid == installedUnitInfoId p + then Just (case mb_indef of + Nothing -> p + Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) + else Nothing + +selectPackages :: PackagePrecedenceIndex -> PackageArg -> [UnitInfo] + -> UnusablePackages + -> Either [(UnitInfo, UnusablePackageReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- | Rename a 'UnitInfo' according to some module instantiation. +renamePackage :: UnitInfoMap -> [(ModuleName, Module)] + -> UnitInfo -> UnitInfo +renamePackage pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) + in conf { + instantiatedWith = new_insts, + exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (exposedModules conf) + } + + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + +matchingId :: InstalledUnitId -> UnitInfo -> Bool +matchingId uid p = uid == installedUnitInfoId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: PackagePrecedenceIndex -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the packages +-- in later package database. +-- +-- Instead, we use that preference based policy only when one of the packages +-- is integer-gmp and the other is integer-simple. +-- This currently only happens when we're looking up which concrete +-- package to use in place of @integer-wired-in@ and that two different +-- package databases supply a different integer library. For more about +-- the fake @integer-wired-in@ package, see Note [The integer library] +-- in the @PrelNames@ module. +compareByPreference + :: PackagePrecedenceIndex + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + , differentIntegerPkgs pkg pkg' + = compare prec prec' + + | otherwise + = case comparing packageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + -- Prefer the package from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + + where isIntegerPkg p = packageNameString p `elem` + ["integer-simple", "integer-gmp"] + differentIntegerPkgs p p' = + isIntegerPkg p && isIntegerPkg p' && + (packageName p /= packageName p') + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering +comparing f a b = f a `compare` f b + +packageFlagErr :: DynFlags + -> PackageFlag + -> [(UnitInfo, UnusablePackageReason)] + -> IO a +packageFlagErr dflags flag reasons + = packageFlagErr' dflags (pprFlag flag) reasons + +trustFlagErr :: DynFlags + -> TrustFlag + -> [(UnitInfo, UnusablePackageReason)] + -> IO a +trustFlagErr dflags flag reasons + = packageFlagErr' dflags (pprTrustFlag flag) reasons + +packageFlagErr' :: DynFlags + -> SDoc + -> [(UnitInfo, UnusablePackageReason)] + -> IO a +packageFlagErr' dflags flag_doc reasons + = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) + where err = text "cannot satisfy " <> flag_doc <> + (if null reasons then Outputable.empty else text ": ") $$ + nest 4 (ppr_reasons $$ + text "(use -v for more information)") + ppr_reasons = vcat (map ppr_reason reasons) + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ----------------------------------------------------------------------------- +-- Wired-in packages +-- +-- See Note [Wired-in packages] in Module + +type WiredInUnitId = String +type WiredPackagesMap = Map WiredUnitId WiredUnitId + +wired_in_unitids :: [WiredInUnitId] +wired_in_unitids = map unitIdString wiredInUnitIds + +findWiredInPackages + :: DynFlags + -> PackagePrecedenceIndex + -> [UnitInfo] -- database + -> VisibilityMap -- info on what packages are visible + -- for wired in selection + -> IO ([UnitInfo], -- package database updated for wired in + WiredPackagesMap) -- map from unit id to wired identity + +findWiredInPackages dflags prec_map pkgs vis_map = do + -- Now we must find our wired-in packages, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in packages] in Module + let + matches :: UnitInfo -> WiredInUnitId -> Bool + pc `matches` pid + -- See Note [The integer library] in PrelNames + | pid == unitIdString integerUnitId + = packageNameString pc `elem` ["integer-gmp", "integer-simple"] + pc `matches` pid = packageNameString pc == pid + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInPackage :: [UnitInfo] -> WiredInUnitId + -> IO (Maybe (WiredInUnitId, UnitInfo)) + findWiredInPackage pkgs wired_pkg = + let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = + [ p | p <- all_ps + , Map.member (packageConfigId p) vis_map ] in + case all_exposed_ps of + [] -> case all_ps of + [] -> notfound + many -> pick (head (sortByPreference prec_map many)) + many -> pick (head (sortByPreference prec_map many)) + where + notfound = do + debugTraceMsg dflags 2 $ + text "wired-in package " + <> text wired_pkg + <> text " not found." + return Nothing + pick :: UnitInfo + -> IO (Maybe (WiredInUnitId, UnitInfo)) + pick pkg = do + debugTraceMsg dflags 2 $ + text "wired-in package " + <> text wired_pkg + <> text " mapped to " + <> ppr (unitId pkg) + return (Just (wired_pkg, pkg)) + + + mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_unitids + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + -- this is old: we used to assume that if there were + -- multiple versions of wired-in packages installed that + -- they were mutually exclusive. Now we're assuming that + -- you have one "main" version of each wired-in package + -- (the latest version), and the others are backward-compat + -- wrappers that depend on this one. e.g. base-4.0 is the + -- latest, base-3.0 is a compat wrapper depending on base-4.0. + {- + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_unitids + && package p `notElem` map fst wired_in_ids + -} + + wiredInMap :: Map WiredUnitId WiredUnitId + wiredInMap = Map.fromList + [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) + | (wiredInUnitId, pkg) <- wired_in_pkgs + , Just key <- pure $ definiteUnitInfoId pkg + ] + + updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs + where upd_pkg pkg + | Just def_uid <- definiteUnitInfoId pkg + , Just wiredInUnitId <- Map.lookup def_uid wiredInMap + = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) + in pkg { + unitId = fsToInstalledUnitId fs, + componentId = ComponentId fs + } + | otherwise + = pkg + upd_deps pkg = pkg { + -- temporary harmless DefUnitId invariant violation + depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), + exposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (exposedModules pkg) + } + + + return (updateWiredInDependencies pkgs, wiredInMap) + +-- Helper functions for rewiring Module and UnitId. These +-- rewrite UnitIds of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in packages] in Module. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in PrelNames. + +upd_wired_in_mod :: WiredPackagesMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId +upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = + DefiniteUnitId (upd_wired_in wiredInMap def_uid) +upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = + IndefiniteUnitId $ newIndefUnitId + (indefUnitIdComponentId indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) + +upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId +upd_wired_in wiredInMap key + | Just key' <- Map.lookup key wiredInMap = key' + | otherwise = key + +updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) + where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of + Nothing -> vm + Just r -> Map.insert (DefiniteUnitId to) r + (Map.delete (DefiniteUnitId from) vm) + + +-- ---------------------------------------------------------------------------- + +-- | The reason why a package is unusable. +data UnusablePackageReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This package transitively depends on a package that was never present + -- in any of the provided databases. + | BrokenDependencies [InstalledUnitId] + -- | This package transitively depends on a package involved in a cycle. + -- Note that the list of 'InstalledUnitId' reports the direct dependencies + -- of this package that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [InstalledUnitId] + -- | This package transitively depends on a package which was ignored. + | IgnoredDependencies [InstalledUnitId] + -- | This package transitively depends on a package which was + -- shadowed by an ABI-incompatible package. + | ShadowedDependencies [InstalledUnitId] + +instance Outputable UnusablePackageReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +type UnusablePackages = Map InstalledUnitId + (UnitInfo, UnusablePackageReason) + +pprReason :: SDoc -> UnusablePackageReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportCycles :: DynFlags -> [SCC UnitInfo] -> IO () +reportCycles dflags sccs = mapM_ report sccs + where + report (AcyclicSCC _) = return () + report (CyclicSCC vs) = + debugTraceMsg dflags 2 $ + text "these packages are involved in a cycle:" $$ + nest 2 (hsep (map (ppr . unitId) vs)) + +reportUnusable :: DynFlags -> UnusablePackages -> IO () +reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg dflags 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'InstalledUnitId' to +-- the 'InstalledUnitId's which have a dependency on it. +type RevIndex = Map InstalledUnitId [InstalledUnitId] + +-- | Compute the reverse dependency index of a package database. +reverseDeps :: InstalledPackageIndex -> RevIndex +reverseDeps db = Map.foldl' go Map.empty db + where + go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) + go' from r to = Map.insertWith (++) to [from] r + +-- | Given a list of 'InstalledUnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those packages, plus any packages which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removePackages :: [InstalledUnitId] -> RevIndex + -> InstalledPackageIndex + -> (InstalledPackageIndex, [UnitInfo]) +removePackages uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- Map.lookup uid m + = case Map.lookup uid index of + Nothing -> go uids (Map.delete uid m, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'InstalledPackageIndex', +-- return all entries in 'depends' which correspond to packages +-- that do not exist in the index. +depsNotAvailable :: InstalledPackageIndex + -> UnitInfo + -> [InstalledUnitId] +depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) + +-- | Given a 'UnitInfo' from some 'InstalledPackageIndex' +-- return all entries in 'abiDepends' which correspond to packages +-- that do not exist, OR have mismatching ABIs. +depsAbiMismatch :: InstalledPackageIndex + -> UnitInfo + -> [InstalledUnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- Map.lookup dep_uid pkg_map + = abiHash dep_pkg == abi + | otherwise + = False + +-- ----------------------------------------------------------------------------- +-- Ignore packages + +ignorePackages :: [IgnorePackageFlag] -> [UnitInfo] -> UnusablePackages +ignorePackages flags pkgs = Map.fromList (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each package, a mapping from uid -> i indicates that this +-- package was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- packages that were defined later on the command line, if there +-- is an ambiguity. +type PackagePrecedenceIndex = Map InstalledUnitId Int + +-- | Given a list of databases, merge them together, where +-- packages with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: DynFlags -> [PackageDatabase] + -> IO (InstalledPackageIndex, PackagePrecedenceIndex) +mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] + where + merge (pkg_map, prec_map) (i, PackageDatabase db_path db) = do + debugTraceMsg dflags 2 $ + text "loading package database" <+> text db_path + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg dflags 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set InstalledUnitId + override_set = Set.intersection (Map.keysSet db_map) + (Map.keysSet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: InstalledPackageIndex + pkg_map' = Map.union db_map pkg_map + + prec_map' :: PackagePrecedenceIndex + prec_map' = Map.union (Map.map (const i) db_map) prec_map + +-- | Validates a database, removing unusable packages from it +-- (this includes removing packages that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken packages (dangling dependencies) +-- 2. Remove all packages that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all packages which have deps with mismatching ABIs +-- +validateDatabase :: DynFlags -> InstalledPackageIndex + -> (InstalledPackageIndex, UnusablePackages, [SCC UnitInfo]) +validateDatabase dflags pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse (ignorePackageFlags dflags) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids ] + + -- Find broken packages + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (Map.elems pkg_map1) + (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive packages + sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) + | pkg <- Map.elems pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) + (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out packages whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (Map.elems pkg_map4) + (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + unusable = directly_ignored `Map.union` unusable_ignored + `Map.union` unusable_broken + `Map.union` unusable_cyclic + `Map.union` unusable_shadowed + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our package +-- settings and populate the package state. + +mkPackageState + :: DynFlags + -- initial databases, in the order they were specified on + -- the command line (later databases shadow earlier ones) + -> [PackageDatabase] + -> [PreloadUnitId] -- preloaded packages + -> IO (PackageState, + [PreloadUnitId], -- new packages to preload + Maybe [(ModuleName, Module)]) + +mkPackageState dflags dbs preload0 = do +{- + Plan. + + There are two main steps for making the package state: + + 1. We want to build a single, unified package database based + on all of the input databases, which upholds the invariant that + there is only one package per any UnitId and there are no + dangling dependencies. We'll do this by merging, and + then successively filtering out bad dependencies. + + a) Merge all the databases together. + If an input database defines unit ID that is already in + the unified database, that package SHADOWS the existing + package in the current unified database. Note that + order is important: packages defined later in the list of + command line arguments shadow those defined earlier. + + b) Remove all packages with missing dependencies, or + mutually recursive dependencies. + + b) Remove packages selected by -ignore-package from input database + + c) Remove all packages which depended on packages that are now + shadowed by an ABI-incompatible package + + d) report (with -v) any packages that were removed by steps 1-3 + + 2. We want to look at the flags controlling package visibility, + and build a mapping of what module names are in scope and + where they live. + + a) on the final, unified database, we apply -trust/-distrust + flags directly, modifying the database so that the 'trusted' + field has the correct value. + + b) we use the -package/-hide-package flags to compute a + visibility map, stating what packages are "exposed" for + the purposes of computing the module map. + * if any flag refers to a package which was removed by 1-5, then + we can give an error message explaining why + * if -hide-all-packages was not specified, this step also + hides packages which are superseded by later exposed packages + * this step is done TWICE if -plugin-package/-hide-all-plugin-packages + are used + + c) based on the visibility map, we pick wired packages and rewrite + them to have the expected unitId. + + d) finally, using the visibility map and the package database, + we build a mapping saying what every in scope module name points to. +-} + + -- This, and the other reverse's that you will see, are due to the fact that + -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order + -- than they are on the command line. + let other_flags = reverse (packageFlags dflags) + debugTraceMsg dflags 2 $ + text "package flags" <+> ppr other_flags + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases dflags dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 + + reportCycles dflags sccs + reportUnusable dflags unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) + (Map.elems pkg_map2) (reverse (trustFlags dflags)) + let prelim_pkg_db = extendUnitInfoMap emptyUnitInfoMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same package name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p + then Map.insert (packageConfigId p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = Map.empty, + uv_explicit = False + } + vm + else vm) + Map.empty pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable + (gopt Opt_HideAllPackages dflags) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 + let pkg_db = extendUnitInfoMap emptyUnitInfoMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags + plugin_vis_map <- + case pluginPackageFlags dflags of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return Map.empty + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = Map.empty + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable + (gopt Opt_HideAllPluginPackages dflags) pkgs1) + plugin_vis_map1 + (reverse (pluginPackageFlags dflags)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = Map.keys (Map.filter uv_explicit vis_map) + + let pkgname_map = foldl' add Map.empty pkgs2 + where add pn_map p + = Map.insert (packageName p) (componentId p) pn_map + + -- The explicitPackages accurately reflects the set of packages we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = Map.keys vis_map + req_ctx = Map.map (Set.toList) + $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) + + + let preload2 = preload1 + + let + -- add base & rts to the preload packages + basicLinkedPackages + | gopt Opt_AutoLinkPackages dflags + = filter (flip elemUDFM (unUnitInfoMap pkg_db)) + [baseUnitId, rtsUnitId] + | otherwise = [] + -- but in any case remove the current package from the set of + -- preloaded packages so that base/rts does not end up in the + -- set up preloaded package when we are just building it + -- (NB: since this is only relevant for base/rts it doesn't matter + -- that thisUnitIdInsts_ is not wired yet) + -- + preload3 = ordNub $ filter (/= thisPackage dflags) + $ (basicLinkedPackages ++ preload2) + + -- Close the preload packages with their dependencies + dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) + let new_dep_preload = filter (`notElem` preload0) dep_preload + + let mod_map1 = mkModuleNameProvidersMap dflags pkg_db vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = Map.union mod_map1 mod_map2 + + dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" + FormatText + (pprModuleMap mod_map) + + -- Force pstate to avoid leaking the dflags0 passed to mkPackageState + let !pstate = PackageState{ + preloadPackages = dep_preload, + explicitPackages = explicit_pkgs, + unitInfoMap = pkg_db, + moduleNameProvidersMap = mod_map, + pluginModuleNameProvidersMap = mkModuleNameProvidersMap dflags pkg_db plugin_vis_map, + packageNameMap = pkgname_map, + unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], + requirementContext = req_ctx + } + let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) + return (pstate, new_dep_preload, new_insts) + +-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' +-- that it was recorded as in the package database. +unwireUnitId :: DynFlags -> UnitId -> UnitId +unwireUnitId dflags uid@(DefiniteUnitId def_uid) = + maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) +unwireUnitId _ uid = uid + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from module to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: DynFlags + -> UnitInfoMap + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap dflags pkg_db vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_db is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_db multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + Map.foldlWithKey extend_modmap emptyMap vis_map_extended + where + vis_map_extended = Map.union vis_map {- preferred -} default_vis + + default_vis = Map.fromList + [ (packageConfigId pkg, mempty) + | pkg <- eltsUDFM (unUnitInfoMap pkg_db) + -- Exclude specific instantiations of an indefinite + -- package + , indefinite pkg || null (instantiatedWith pkg) + ] + + emptyMap = Map.empty + setOrigins m os = fmap (const os) m + extend_modmap modmap uid + UnitVisibility { uv_expose_all = b, uv_renamings = rns } + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, Map Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, Map Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (showSDoc dflags + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + let pkg' = unit_lookup pk' + in (pk', m', fromReexportedModules e pkg') + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM (Map Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = packageConfigId pkg + unit_lookup uid = lookupUnit' (isIndefinite dflags) pkg_db uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusablePackages -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + Map.foldl' extend_modmap Map.empty unusables + where + extend_modmap modmap (pkg, reason) = addListTo modmap bindings + where bindings :: [(ModuleName, Map Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin = ModUnusable reason + pkg_id = packageConfigId pkg + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] + + get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) + get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2) + => Map k1 (Map k2 a) + -> [(k1, Map k2 a)] + -> Map k1 (Map k2 a) +addListTo = foldl' merge + where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m + +-- | Create a singleton module mapping +mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin +mkModMap pkg mod = Map.singleton (mkModule pkg mod) + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Find all the include directories in these and the preload packages +getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageIncludePath dflags pkgs = + collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs + +collectIncludeDirs :: [UnitInfo] -> [FilePath] +collectIncludeDirs ps = ordNub (filter notNull (concatMap includeDirs ps)) + +-- | Find all the library paths in these and the preload packages +getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageLibraryPath dflags pkgs = + collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath] +collectLibraryPaths dflags = ordNub . filter notNull + . concatMap (libraryDirsForWay dflags) + +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) +getPackageLinkOpts dflags pkgs = + collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . extraLibraries) ps, + concatMap ldOptions ps + ) +collectArchives :: DynFlags -> UnitInfo -> IO [FilePath] +collectArchives dflags pc = + filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a") + | searchPath <- searchPaths + , lib <- libs ] + where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc + libs = packageHsLibs dflags pc ++ extraLibraries pc + +getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)] +getLibs dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + fmap concat . forM ps $ \p -> do + let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] + filterM (doesFileExist . fst) candidates + +packageHsLibs :: DynFlags -> UnitInfo -> [String] +packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) + where + ways0 = ways dflags + + ways1 = filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc<version>.so + -- we leave out the _dyn, because it is superfluous + + -- debug and profiled RTSs include support for -eventlog + ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 + = filter (/= WayEventLog) ways1 + | otherwise + = ways1 + + tag = mkBuildTag (filter (not . wayRTSOnly) ways2) + rts_tag = mkBuildTag ways2 + + mkDynName x + | WayDyn `notElem` ways dflags = x + | "HS" `isPrefixOf` x = + x ++ '-':programName dflags ++ projectVersion dflags + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package for + -- example in ghc-cabal. + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t + +-- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. +libraryDirsForWay :: DynFlags -> UnitInfo -> [String] +libraryDirsForWay dflags + | WayDyn `elem` ways dflags = libraryDynDirs + | otherwise = libraryDirs + +-- | Find all the C-compiler options in these and the preload packages +getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageExtraCcOpts dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap ccOptions ps) + +-- | Find all the package framework paths in these and the preload packages +getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageFrameworkPath dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (ordNub (filter notNull (concatMap frameworkDirs ps))) + +-- | Find all the package frameworks in these and the preload packages +getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageFrameworks dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap frameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllPackages :: DynFlags + -> ModuleName + -> [(Module, UnitInfo)] +lookupModuleInAllPackages dflags m + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupUnit dflags + (moduleUnitId m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module UnitInfo + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | No modules found, but there were some unusable ones with + -- an exact name match + | LookupUnusable [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags + = lookupModuleWithSuggestions' dflags + (moduleNameProvidersMap (pkgState dflags)) + +lookupPluginModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupPluginModuleWithSuggestions dflags + = lookupModuleWithSuggestions' dflags + (pluginModuleNameProvidersMap (pkgState dflags)) + +lookupModuleWithSuggestions' :: DynFlags + -> ModuleNameProvidersMap + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions' dflags mod_map m mb_pn + = case Map.lookup m mod_map of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[], []) (Map.toList xs) of + ([], [], [], []) -> LookupNotFound suggestions + (_, _, _, [(m, _)]) -> LookupFound m (mod_unit m) + (_, _, _, exposed@(_:_)) -> LookupMultiple exposed + ([], [], unusable@(_:_), []) -> LookupUnusable unusable + (hidden_pkg, hidden_mod, _, []) -> + LookupHidden hidden_pkg hidden_mod + where + classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_unit m) origin0 + x = (m, origin) + in case origin of + ModHidden + -> (hidden_pkg, x:hidden_mod, unusable, exposed) + ModUnusable _ + -> (hidden_pkg, hidden_mod, x:unusable, exposed) + _ | originEmpty origin + -> (hidden_pkg, hidden_mod, unusable, exposed) + | originVisible origin + -> (hidden_pkg, hidden_mod, unusable, x:exposed) + | otherwise + -> (x:hidden_pkg, hidden_mod, unusable, exposed) + + unit_lookup p = lookupUnit dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) + mod_unit = unit_lookup . moduleUnitId + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> UnitInfo + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + (ModUnusable _) -> if go pkg then o else mempty + ModOrigin { fromOrigPackage = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + + suggestions + | gopt Opt_HelpfulErrors dflags = + fuzzyLookup (moduleNameString m) all_mods + | otherwise = [] + + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleNameProvidersMap (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + map fst (filter visible (Map.toList (moduleNameProvidersMap (pkgState dflags)))) + where visible (_, ms) = any originVisible (Map.elems ms) + +-- | Find all the 'UnitInfo' in both the preload packages from 'DynFlags' and corresponding to the list of +-- 'UnitInfo's +getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [UnitInfo] +getPreloadPackagesAnd dflags pkgids0 = + let + pkgids = pkgids0 ++ + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + if isIndefinite dflags + then [] + else map (toInstalledUnitId . moduleUnitId . snd) + (thisUnitIdInsts dflags) + state = pkgState dflags + pkg_map = unitInfoMap state + preload = preloadPackages state + pairs = zip pkgids (repeat Nothing) + in do + all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) + return (map (getInstalledPackageDetails dflags) all_pkgs) + +-- Takes a list of packages, and returns the list with dependencies included, +-- in reverse dependency order (a package appears before those it depends on). +closeDeps :: DynFlags + -> UnitInfoMap + -> [(InstalledUnitId, Maybe InstalledUnitId)] + -> IO [InstalledUnitId] +closeDeps dflags pkg_map ps + = throwErr dflags (closeDepsErr dflags pkg_map ps) + +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) + Succeeded r -> return r + +closeDepsErr :: DynFlags + -> UnitInfoMap + -> [(InstalledUnitId,Maybe InstalledUnitId)] + -> MaybeErr MsgDoc [InstalledUnitId] +closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps + +-- internal helper +add_package :: DynFlags + -> UnitInfoMap + -> [PreloadUnitId] + -> (PreloadUnitId,Maybe PreloadUnitId) + -> MaybeErr MsgDoc [PreloadUnitId] +add_package dflags pkg_db ps (p, mb_parent) + | p `elem` ps = return ps -- Check if we've already added this package + | otherwise = + case lookupInstalledPackage' pkg_db p of + Nothing -> Failed (missingPackageMsg p <> + missingDependencyMsg mb_parent) + Just pkg -> do + -- Add the package's dependents also + ps' <- foldM add_unit_key ps (depends pkg) + return (p : ps') + where + add_unit_key ps key + = add_package dflags pkg_db ps (key, Just p) + +missingPackageMsg :: Outputable pkgid => pkgid -> SDoc +missingPackageMsg p = text "unknown package:" <+> ppr p + +missingDependencyMsg :: Maybe InstalledUnitId -> SDoc +missingDependencyMsg Nothing = Outputable.empty +missingDependencyMsg (Just parent) + = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) + +-- ----------------------------------------------------------------------------- + +componentIdString :: DynFlags -> ComponentId -> Maybe String +componentIdString dflags cid = do + conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) + return $ + case sourceLibName conf of + Nothing -> sourcePackageIdString conf + Just (PackageName libname) -> + packageNameString conf + ++ "-" ++ showVersion (packageVersion conf) + ++ ":" ++ unpackFS libname + +displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +displayInstalledUnitId dflags uid = + fmap sourcePackageIdString (lookupInstalledPackage dflags uid) + +-- | Will the 'Name' come from a dynamically linked library? +isDllName :: DynFlags -> Module -> Name -> Bool +-- Despite the "dll", I think this function just means that +-- the symbol comes from another dynamically-linked package, +-- and applies on all platforms, not just Windows +isDllName dflags this_mod name + | not (gopt Opt_ExternalDynamicRefs dflags) = False + | Just mod <- nameModule_maybe name + -- Issue #8696 - when GHC is dynamically linked, it will attempt + -- to load the dynamic dependencies of object files at compile + -- time for things like QuasiQuotes or + -- TemplateHaskell. Unfortunately, this interacts badly with + -- intra-package linking, because we don't generate indirect + -- (dynamic) symbols for intra-package calls. This means that if a + -- module with an intra-package call is loaded without its + -- dependencies, then GHC fails to link. This is the cause of # + -- + -- In the mean time, always force dynamic indirections to be + -- generated: when the module name isn't the module being + -- compiled, references are dynamic. + = case platformOS $ targetPlatform dflags of + -- On Windows the hack for #8696 makes it unlinkable. + -- As the entire setup of the code from Cmm down to the RTS expects + -- the use of trampolines for the imported functions only when + -- doing intra-package linking, e.g. referring to a symbol defined in the same + -- package should not use a trampoline. + -- I much rather have dynamic TH not supported than the entire Dynamic linking + -- not due to a hack. + -- Also not sure this would break on Windows anyway. + OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod + + -- For the other platforms, still perform the hack + _ -> mod /= this_mod + + | otherwise = False -- no, it is not even an external name + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +-- | Show (very verbose) package info +pprPackages :: DynFlags -> SDoc +pprPackages = pprPackagesWith pprUnitInfo + +pprPackagesWith :: (UnitInfo -> SDoc) -> DynFlags -> SDoc +pprPackagesWith pprIPI dflags = + vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap dflags))) + +-- | Show simplified package info. +-- +-- The idea is to only print package id, and any information that might +-- be different from the package databases (exposure, trust) +pprPackagesSimple :: DynFlags -> SDoc +pprPackagesSimple = pprPackagesWith pprIPI + where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) + e = if exposed ipi then text "E" else text " " + t = if trusted ipi then text "T" else text " " + in e <> t <> text " " <> ftext i + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (Map.toList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: UnitInfo -> FastString +fsPackageName = mkFastString . packageNameString + +-- | Given a fully instantiated 'UnitId', improve it into a +-- 'InstalledUnitId' if we can find it in the package database. +improveUnitId :: UnitInfoMap -> UnitId -> UnitId +improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit +improveUnitId pkg_map uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupUnit' False pkg_map uid of + Nothing -> uid + Just pkg -> + -- Do NOT improve if the indefinite unit id is not + -- part of the closure unique set. See + -- Note [UnitId to InstalledUnitId improvement] + if installedUnitInfoId pkg `elementOfUniqSet` preloadClosure pkg_map + then packageConfigId pkg + else uid + +-- | Retrieve the 'UnitInfoMap' from 'DynFlags'; used +-- in the @hs-boot@ loop-breaker. +getUnitInfoMap :: DynFlags -> UnitInfoMap +getUnitInfoMap = unitInfoMap . pkgState diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot new file mode 100644 index 0000000000..89fb2a1c18 --- /dev/null +++ b/compiler/GHC/Driver/Packages.hs-boot @@ -0,0 +1,12 @@ +module GHC.Driver.Packages where +import GhcPrelude +import {-# SOURCE #-} GHC.Driver.Session (DynFlags) +import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) +data PackageState +data UnitInfoMap +data PackageDatabase +emptyPackageState :: PackageState +componentIdString :: DynFlags -> ComponentId -> Maybe String +displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +improveUnitId :: UnitInfoMap -> UnitId -> UnitId +getUnitInfoMap :: DynFlags -> UnitInfoMap diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs new file mode 100644 index 0000000000..45cb4656ba --- /dev/null +++ b/compiler/GHC/Driver/Phases.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Phases ( + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + Phase(..), + happensBefore, eqPhase, anyHsc, isStopLn, + startPhase, + phaseInputExt, + + isHaskellishSuffix, + isHaskellSrcSuffix, + isBackpackishSuffix, + isObjectSuffix, + isCishSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isHaskellSigSuffix, + isSourceSuffix, + + isHaskellishTarget, + + isHaskellishFilename, + isHaskellSrcFilename, + isHaskellSigFilename, + isObjectFilename, + isCishFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Driver.Session +import Outputable +import GHC.Platform +import System.FilePath +import Binary +import Util + +----------------------------------------------------------------------------- +-- Phases + +{- + Phase of the | Suffix saying | Flag saying | (suffix of) + compilation system | ``start here''| ``stop after''| output file + + literate pre-processor | .lhs | - | - + C pre-processor (opt.) | - | -E | - + Haskell compiler | .hs | -C, -S | .hc, .s + C compiler (opt.) | .hc or .c | -S | .s + assembler | .s or .S | -c | .o + linker | other | - | a.out +-} + +-- Note [HscSource types] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- There are three types of source file for Haskell code: +-- +-- * HsSrcFile is an ordinary hs file which contains code, +-- +-- * HsBootFile is an hs-boot file, which is used to break +-- recursive module imports (there will always be an +-- HsSrcFile associated with it), and +-- +-- * HsigFile is an hsig file, which contains only type +-- signatures and is used to specify signatures for +-- modules. +-- +-- Syntactically, hs-boot files and hsig files are quite similar: they +-- only include type signatures and must be associated with an +-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code +-- which is indifferent to which. However, there are some important +-- differences, mostly owing to the fact that hsigs are proper +-- modules (you `import Sig` directly) whereas HsBootFiles are +-- temporary placeholders (you `import {-# SOURCE #-} Mod). +-- When we finish compiling the true implementation of an hs-boot, +-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +-- other hand, is never replaced (in particular, we *cannot* use the +-- HomeModInfo of the original HsSrcFile backing the signature, since it +-- will export too many symbols.) +-- +-- Additionally, while HsSrcFile is the only Haskell file +-- which has *code*, we do generate .o files for HsigFile, because +-- this is how the recompilation checker figures out if a file +-- needs to be recompiled. These are fake object files which +-- should NOT be linked against. + +data HscSource + = HsSrcFile | HsBootFile | HsigFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + +instance Binary HscSource where + put_ bh HsSrcFile = putByte bh 0 + put_ bh HsBootFile = putByte bh 1 + put_ bh HsigFile = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return HsSrcFile + 1 -> return HsBootFile + _ -> return HsigFile + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" + +-- See Note [isHsBootOrSig] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig HsBootFile = True +isHsBootOrSig HsigFile = True +isHsBootOrSig _ = False + +isHsigFile :: HscSource -> Bool +isHsigFile HsigFile = True +isHsigFile _ = False + +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Ccxx -- Compile C++ + | Cc -- Compile C + | Cobjc -- Compile Objective-C + | Cobjcxx -- Compile Objective-C++ + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly + | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + | MergeForeign -- merge in the foreign object files + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +instance Outputable Phase where + ppr p = text (show p) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn _ = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True +eqPhase HCc HCc = True +eqPhase (As x) (As y) = x == y +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase MergeForeign MergeForeign = True +eqPhase StopLn StopLn = True +eqPhase Ccxx Ccxx = True +eqPhase Cobjcxx Cobjcxx = True +eqPhase _ _ = False + +{- Note [Partial ordering on phases] + +We want to know which phases will occur before which others. This is used for +sanity checking, to ensure that the pipeline will stop at some point (see +GHC.Driver.Pipeline.runPipeline). + +A < B iff A occurs before B in a normal compilation pipeline. + +There is explicitly not a total ordering on phases, because in registerised +builds, the phase `HsC` doesn't happen before nor after any other phase. + +Although we check that a normal user doesn't set the stop_phase to HsC through +use of -C with registerised builds (in Main.checkOptions), it is still +possible for a ghc-api user to do so. So be careful when using the function +happensBefore, and don't think that `not (a <= b)` implies `b < a`. +-} +happensBefore :: DynFlags -> Phase -> Phase -> Bool +happensBefore dflags p1 p2 = p1 `happensBefore'` p2 + where StopLn `happensBefore'` _ = False + x `happensBefore'` y = after_x `eqPhase` y + || after_x `happensBefore'` y + where after_x = nextPhase dflags x + +nextPhase :: DynFlags -> Phase -> Phase +nextPhase dflags p + -- A conservative approximation to the next phase, used in happensBefore + = case p of + Unlit sf -> Cpp sf + Cpp sf -> HsPp sf + HsPp sf -> Hsc sf + Hsc _ -> maybeHCc + LlvmOpt -> LlvmLlc + LlvmLlc -> LlvmMangle + LlvmMangle -> As False + As _ -> MergeForeign + Ccxx -> As False + Cc -> As False + Cobjc -> As False + Cobjcxx -> As False + CmmCpp -> Cmm + Cmm -> maybeHCc + HCc -> As False + MergeForeign -> StopLn + StopLn -> panic "nextPhase: nothing after StopLn" + where maybeHCc = if platformUnregisterised (targetPlatform dflags) + then HCc + else As False + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase :: String -> Phase +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Ccxx +startPhase "C" = Cc +startPhase "m" = Cobjc +startPhase "M" = Cobjcxx +startPhase "mm" = Cobjcxx +startPhase "cc" = Ccxx +startPhase "cxx" = Ccxx +startPhase "s" = As False +startPhase "S" = As True +startPhase "ll" = LlvmOpt +startPhase "bc" = LlvmLlc +startPhase "lm_s" = LlvmMangle +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt :: Phase -> String +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Ccxx = "cpp" +phaseInputExt Cobjc = "m" +phaseInputExt Cobjcxx = "mm" +phaseInputExt Cc = "c" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" +phaseInputExt LlvmOpt = "ll" +phaseInputExt LlvmLlc = "bc" +phaseInputExt LlvmMangle = "lm_s" +phaseInputExt CmmCpp = "cmmcpp" +phaseInputExt Cmm = "cmm" +phaseInputExt MergeForeign = "o" +phaseInputExt StopLn = "o" + +haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, + haskellish_user_src_suffixes, haskellish_sig_suffixes + :: [String] +-- When a file with an extension in the haskellish_src_suffixes group is +-- loaded in --make mode, its imports will be loaded too. +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp" ] +haskellish_suffixes = haskellish_src_suffixes ++ + [ "hc", "cmm", "cmmcpp" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] + +-- Will not be deleted as temp files: +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] +backpackish_suffixes = [ "bkp" ] + +objish_suffixes :: Platform -> [String] +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] + +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib", "so"] + _ -> ["so"] + +isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, + isHaskellUserSrcSuffix, isHaskellSigSuffix + :: String -> Bool +isHaskellishSuffix s = s `elem` haskellish_suffixes +isBackpackishSuffix s = s `elem` backpackish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform + +isSourceSuffix :: String -> Bool +isSourceSuffix suff = isHaskellishSuffix suff + || isCishSuffix suff + || isBackpackishSuffix suff + +-- | When we are given files (modified by -x arguments) we need +-- to determine if they are Haskellish or not to figure out +-- how we should try to compile it. The rules are: +-- +-- 1. If no -x flag was specified, we check to see if +-- the file looks like a module name, has no extension, +-- or has a Haskell source extension. +-- +-- 2. If an -x flag was specified, we just make sure the +-- specified suffix is a Haskell one. +isHaskellishTarget :: (String, Maybe Phase) -> Bool +isHaskellishTarget (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) +isHaskellishTarget (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + , StopLn] + +isHaskellishFilename, isHaskellSrcFilename, isCishFilename, + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + :: FilePath -> Bool +-- takeExtension return .foo, so we drop 1 to get rid of the . +isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) +isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) +isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) +isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) + +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs new file mode 100644 index 0000000000..3c31e34eb8 --- /dev/null +++ b/compiler/GHC/Driver/Pipeline.hs @@ -0,0 +1,2340 @@ +{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Pipeline ( + -- Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- Interfaces for the batch-mode driver + linkBinary, + + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compileOne, compileOne', + link, + + -- Exports for hooks to override runPhase and link + PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), + phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, + hscPostBackendPhase, getLocation, setModLocation, setDynFlags, + runPhase, exeFileName, + maybeCreateManifest, + doCpp, + linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode + ) where + +#include <ghcplatform.h> +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Packages +import HeaderInfo +import GHC.Driver.Phases +import SysTools +import SysTools.ExtraObj +import GHC.Driver.Main +import GHC.Driver.Finder +import GHC.Driver.Types hiding ( Hsc ) +import Outputable +import Module +import ErrUtils +import GHC.Driver.Session +import Panic +import Util +import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) +import BasicTypes ( SuccessFlag(..) ) +import Maybes ( expectJust ) +import SrcLoc +import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) +import MonadUtils +import GHC.Platform +import TcRnTypes +import ToolSettings +import GHC.Driver.Hooks +import qualified GHC.LanguageExtensions as LangExt +import FileCleanup +import Ar +import Bag ( unitBag ) +import FastString ( mkFastString ) +import GHC.Iface.Utils ( mkFullIface ) +import UpdateCafInfos ( updateModDetailsCafInfos ) + +import Exception +import System.Directory +import System.FilePath +import System.IO +import Control.Monad +import Data.List ( isInfixOf, intercalate ) +import Data.Maybe +import Data.Version +import Data.Either ( partitionEithers ) + +import Data.Time ( UTCTime ) + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: HscEnv + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either ErrorMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + ghandle handler $ + fmap Right $ do + MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) + (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) + Nothing + -- We keep the processed file for the whole session to save on + -- duplicated work in ghci. + (Temporary TFL_GhcSession) + Nothing{-no ModLocation-} + []{-no foreign objects-} + -- We stop before Hsc phase so we shouldn't generate an interface + MASSERT(isNothing mb_iface) + return (dflags, fp) + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = return $ Left $ unitBag $ + mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + handler ex = throwGhcExceptionIO ex + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. +-- +-- NB. No old interface can also mean that the source has changed. + +compileOne :: HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne = compileOne' Nothing (Just batchMsg) + +compileOne' :: Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne' m_tc_result mHscMessage + hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable + source_modified0 + = do + + debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) + + -- Run the pipeline up to codeGen (so everything up to, but not including, STG) + (status, plugin_dflags) <- hscIncrementalCompile + always_do_basic_recompilation_check + m_tc_result mHscMessage + hsc_env summary source_modified mb_old_iface (mod_index, nmods) + + let flags = hsc_dflags hsc_env0 + in do unless (gopt Opt_KeepHiFiles flags) $ + addFilesToClean flags TFL_CurrentModule $ + [ml_hi_file $ ms_location summary] + unless (gopt Opt_KeepOFiles flags) $ + addFilesToClean flags TFL_GhcSession $ + [ml_obj_file $ ms_location summary] + + -- Use an HscEnv with DynFlags updated with the plugin info (returned from + -- hscIncrementalCompile) + let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } + + case (status, hsc_lang) of + (HscUpToDate iface hmi_details, _) -> + -- TODO recomp014 triggers this assert. What's going on?! + -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) + return $! HomeModInfo iface hmi_details mb_old_linkable + (HscNotGeneratingCode iface hmi_details, HscNothing) -> + let mb_linkable = if isHsBootOrSig src_flavour + then Nothing + -- TODO: Questionable. + else Just (LM (ms_hs_date summary) this_mod []) + in return $! HomeModInfo iface hmi_details mb_linkable + (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" + (_, HscNothing) -> panic "compileOne HscNothing" + (HscUpdateBoot iface hmi_details, HscInterpreted) -> do + return $! HomeModInfo iface hmi_details Nothing + (HscUpdateBoot iface hmi_details, _) -> do + touchObjectFile dflags object_filename + return $! HomeModInfo iface hmi_details Nothing + (HscUpdateSig iface hmi_details, HscInterpreted) -> do + let !linkable = LM (ms_hs_date summary) this_mod [] + return $! HomeModInfo iface hmi_details (Just linkable) + (HscUpdateSig iface hmi_details, _) -> do + output_fn <- getOutputFilename next_phase + (Temporary TFL_CurrentModule) basename dflags + next_phase (Just location) + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + _ <- runPipeline StopLn hsc_env' + (output_fn, + Nothing, + Just (HscOut src_flavour + mod_name (HscUpdateSig iface hmi_details))) + (Just basename) + Persistent + (Just location) + [] + o_time <- getModificationUTCTime object_filename + let !linkable = LM o_time this_mod [DotO object_filename] + return $! HomeModInfo iface hmi_details (Just linkable) + (HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_mod_details = hmi_details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing + liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary) + + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc spt_entries] + unlinked_time = ms_hs_date summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let !linkable = LM unlinked_time (ms_mod summary) + (hs_unlinked ++ stub_o) + return $! HomeModInfo final_iface hmi_details (Just linkable) + (HscRecomp{}, _) -> do + output_fn <- getOutputFilename next_phase + (Temporary TFL_CurrentModule) + basename dflags next_phase (Just location) + -- We're in --make mode: finish the compilation pipeline. + (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env' + (output_fn, + Nothing, + Just (HscOut src_flavour mod_name status)) + (Just basename) + Persistent + (Just location) + [] + -- The object filename comes from the ModLocation + o_time <- getModificationUTCTime object_filename + let !linkable = LM o_time this_mod [DotO object_filename] + return $! HomeModInfo iface details (Just linkable) + + where dflags0 = ms_hspp_opts summary + this_mod = ms_mod summary + location = ms_location summary + input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fnpp = ms_hspp_file summary + mod_graph = hsc_mod_graph hsc_env0 + needsLinker = needsTemplateHaskellOrQQ mod_graph + isDynWay = any (== WayDyn) (ways dflags0) + isProfWay = any (== WayProf) (ways dflags0) + internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) + + src_flavour = ms_hsc_src summary + mod_name = ms_mod_name summary + next_phase = hscPostBackendPhase src_flavour hsc_lang + object_filename = ml_obj_file location + + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + dflags1 = if dynamicGhc && internalInterpreter && + not isDynWay && not isProfWay && needsLinker + then gopt_set dflags0 Opt_BuildDynamicToo + else dflags0 + + -- #16331 - when no "internal interpreter" is available but we + -- need to process some TemplateHaskell or QuasiQuotes, we automatically + -- turn on -fexternal-interpreter. + dflags2 = if not internalInterpreter && needsLinker + then gopt_set dflags1 Opt_ExternalInterpreter + else dflags1 + + basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import + -- path. This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + current_dir = takeDirectory basename + old_paths = includePaths dflags2 + !prevailing_dflags = hsc_dflags hsc_env0 + dflags = + dflags2 { includePaths = addQuoteInclude old_paths [current_dir] + , log_action = log_action prevailing_dflags } + -- use the prevailing log_action / log_finaliser, + -- not the one cached in the summary. This is so + -- that we can change the log_action without having + -- to re-summarize all the source files. + hsc_env = hsc_env0 {hsc_dflags = dflags} + + -- Figure out what lang we're generating + hsc_lang = hscTarget dflags + + -- -fforce-recomp should also work with --make + force_recomp = gopt Opt_ForceRecomp dflags + source_modified + | force_recomp = SourceModified + | otherwise = source_modified0 + + always_do_basic_recompilation_check = case hsc_lang of + HscInterpreted -> True + _ -> False + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support), and cc files. + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeForeigns phase). +-- +-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files +-- from TH, that are then compiled and linked to the module. This is +-- useful to implement facilities such as inline-c. + +compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileForeign _ RawObject object_file = return object_file +compileForeign hsc_env lang stub_c = do + let phase = case lang of + LangC -> Cc + LangCxx -> Ccxx + LangObjc -> Cobjc + LangObjcxx -> Cobjcxx + LangAsm -> As True -- allow CPP + RawObject -> panic "compileForeign: should be unreachable" + (_, stub_o, _) <- runPipeline StopLn hsc_env + (stub_c, Nothing, Just (RealPhase phase)) + Nothing (Temporary TFL_GhcSession) + Nothing{-no ModLocation-} + [] + return stub_o + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c + +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () +compileEmptyStub dflags hsc_env basename location mod_name = do + -- To maintain the invariant that every Haskell file + -- compiles to object code, we make an empty (but + -- valid) stub object file for signatures. However, + -- we make sure this object file has a unique symbol, + -- so that ranlib on OS X doesn't complain, see + -- https://gitlab.haskell.org/ghc/ghc/issues/12673 + -- and https://github.com/haskell/cabal/issues/2257 + empty_stub <- newTempName dflags TFL_CurrentModule "c" + let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) + _ <- runPipeline StopLn hsc_env + (empty_stub, Nothing, Nothing) + (Just basename) + Persistent + (Just location) + [] + return () + +-- --------------------------------------------------------------------------- +-- Link + +link :: GhcLink -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +link ghcLink dflags + = lookupHook linkHook l dflags ghcLink dflags + where + l LinkInMemory _ _ _ + = if platformMisc_ghcWithInterpreter $ platformMisc dflags + then -- Not Linking...(demand linker will do the job) + return Succeeded + else panicBadLink LinkInMemory + + l NoLink _ _ _ + = return Succeeded + + l LinkBinary dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkStaticLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkDynLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + +link' :: DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +link' dflags batch_attempt_linking hpt + | batch_attempt_linking + = do + let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + home_mod_infos = eltsHpt hpt + + -- the packages we depend on + pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName staticLink dflags + + linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps + + if not (gopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") + return Succeeded + else do + + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + LinkBinary -> linkBinary + LinkStaticLib -> linkStaticLib + LinkDynLib -> linkDynLibCheck + other -> panicBadLink other + link dflags obj_files pkg_deps + + debugTraceMsg dflags 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool +linkingNeeded dflags staticLink linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let exe_file = exeFileName staticLink dflags + e_exe_time <- tryIO $ getModificationUTCTime exe_file + case e_exe_time of + Left _ -> return True + Right t -> do + -- first check object files and extra_ld_inputs + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs + let (errs,extra_times) = partitionEithers e_extra_times + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return True + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib) + | Just c <- map (lookupInstalledPackage dflags) pkg_deps, + lib <- packageHsLibs dflags c ] + + pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs + if any isNothing pkg_libfiles then return True else do + e_lib_times <- mapM (tryIO . getModificationUTCTime) + (catMaybes pkg_libfiles) + let (lib_errs,lib_times) = partitionEithers e_lib_times + if not (null lib_errs) || any (t <) lib_times + then return True + else checkLinkInfo dflags pkg_deps exe_file + +findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) +findHSLib dflags dirs lib = do + let batch_lib_file = if WayDyn `notElem` ways dflags + then "lib" ++ lib <.> "a" + else mkSOName (targetPlatform dflags) lib + found <- filterM doesFileExist (map (</> batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () +oneShot hsc_env stop_phase srcs = do + o_files <- mapM (compileFile hsc_env stop_phase) srcs + doLink (hsc_dflags hsc_env) stop_phase o_files + +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile hsc_env stop_phase (src, mb_phase) = do + exists <- doesFileExist src + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + -- If we are doing -fno-code, then act as if the output is + -- 'Temporary'. This stops GHC trying to copy files to their + -- final location. + | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule + | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + + ( _, out_file, _) <- runPipeline stop_phase hsc_env + (src, Nothing, fmap RealPhase mb_phase) + Nothing + output + Nothing{-no ModLocation-} [] + return out_file + + +doLink :: DynFlags -> Phase -> [FilePath] -> IO () +doLink dflags stop_phase o_files + | not (isStopLn stop_phase) + = return () -- We stopped before the linking phase + + | otherwise + = case ghcLink dflags of + NoLink -> return () + LinkBinary -> linkBinary dflags o_files [] + LinkStaticLib -> linkStaticLib dflags o_files [] + LinkDynLib -> linkDynLibCheck dflags o_files [] + other -> panicBadLink other + + +-- --------------------------------------------------------------------------- + +-- | Run a compilation pipeline, consisting of multiple phases. +-- +-- This is the interface to the compilation pipeline, which runs +-- a series of compilation steps on a single source file, specifying +-- at which stage to stop. +-- +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- OPTIONS_GHC pragmas), and the changes affect later phases in the +-- pipeline. +runPipeline + :: Phase -- ^ When to stop + -> HscEnv -- ^ Compilation environment + -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) + -- ^ Pipeline input file name, optional + -- buffer and maybe -x suffix + -> Maybe FilePath -- ^ original basename (if different from ^^^) + -> PipelineOutput -- ^ Output filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> [FilePath] -- ^ foreign objects + -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails)) + -- ^ (final flags, output filename, interface) +runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) + mb_basename output maybe_loc foreign_os + + = do let + dflags0 = hsc_dflags hsc_env0 + + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + (input_basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + basename | Just b <- mb_basename = b + | otherwise = input_basename + + -- If we were given a -x flag, then use that phase to start from + start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase + + isHaskell (RealPhase (Unlit _)) = True + isHaskell (RealPhase (Cpp _)) = True + isHaskell (RealPhase (HsPp _)) = True + isHaskell (RealPhase (Hsc _)) = True + isHaskell (HscOut {}) = True + isHaskell _ = False + + isHaskellishFile = isHaskell start_phase + + env = PipeEnv{ stop_phase, + src_filename = input_fn, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + when (isBackpackishSuffix suffix') $ + throwGhcExceptionIO (UsageError + ("use --backpack to process " ++ input_fn)) + + -- We want to catch cases of "you can't get there from here" before + -- we start the pipeline, because otherwise it will just run off the + -- end. + let happensBefore' = happensBefore dflags + case start_phase of + RealPhase start_phase' -> + -- See Note [Partial ordering on phases] + -- Not the same as: (stop_phase `happensBefore` start_phase') + when (not (start_phase' `happensBefore'` stop_phase || + start_phase' `eqPhase` stop_phase)) $ + throwGhcExceptionIO (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + HscOut {} -> return () + + -- Write input buffer to temp file if requested + input_fn' <- case (start_phase, mb_input_buf) of + (RealPhase real_start_phase, Just input_buf) -> do + let suffix = phaseInputExt real_start_phase + fn <- newTempName dflags TFL_CurrentModule suffix + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + (_, _) -> return input_fn + + debugTraceMsg dflags 4 (text "Running the pipeline") + r <- runPipeline' start_phase hsc_env env input_fn' + maybe_loc foreign_os + + -- If we are compiling a Haskell module, and doing + -- -dynamic-too, but couldn't do the -dynamic-too fast + -- path, then rerun the pipeline for the dyn way + let dflags = hsc_dflags hsc_env + -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) + when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do + when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do + debugTraceMsg dflags 4 + (text "Running the pipeline again for -dynamic-too") + let dflags' = dynamicTooMkDynamicDynFlags dflags + hsc_env' <- newHscEnv dflags' + _ <- runPipeline' start_phase hsc_env' env input_fn' + maybe_loc foreign_os + return () + return r + +runPipeline' + :: PhasePlus -- ^ When to start + -> HscEnv -- ^ Compilation environment + -> PipeEnv + -> FilePath -- ^ Input filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> [FilePath] -- ^ foreign objects, if we have one + -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails)) + -- ^ (final flags, output filename, interface) +runPipeline' start_phase hsc_env env input_fn + maybe_loc foreign_os + = do + -- Execute the pipeline... + let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing } + (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state + return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state) + +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + env <- getPipeEnv + dflags <- getDynFlags + -- See Note [Partial ordering on phases] + let happensBefore' = happensBefore dflags + stopPhase = stop_phase env + case phase of + RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done + -> -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + case output_spec env of + Temporary _ -> + return input_fn + output -> + do pst <- getPipeState + final_fn <- liftIO $ getOutputFilename + stopPhase output (src_basename env) + dflags stopPhase (maybe_loc pst) + when (final_fn /= input_fn) $ do + let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") + line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") + liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn + return final_fn + + + | not (realPhase `happensBefore'` stopPhase) + -- Something has gone wrong. We'll try to cover all the cases when + -- this could happen, so if we reach here it is a panic. + -- eg. it might happen if the -C flag is used on a source file that + -- has {-# OPTIONS -fasm #-}. + -> panic ("pipeLoop: at phase " ++ show realPhase ++ + " but I wanted to stop at phase " ++ show stopPhase) + + _ + -> do liftIO $ debugTraceMsg dflags 4 + (text "Running phase" <+> ppr phase) + (next_phase, output_fn) <- runHookedPhase phase input_fn dflags + case phase of + HscOut {} -> do + -- We don't pass Opt_BuildDynamicToo to the backend + -- in DynFlags. + -- Instead it's run twice with flags accordingly set + -- per run. + let noDynToo = pipeLoop next_phase output_fn + let dynToo = do + setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo + r <- pipeLoop next_phase output_fn + setDynFlags $ dynamicTooMkDynamicDynFlags dflags + -- TODO shouldn't ignore result: + _ <- pipeLoop phase input_fn + return r + ifGeneratingDynamicToo dflags dynToo noDynToo + _ -> pipeLoop next_phase output_fn + +runHookedPhase :: PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath) +runHookedPhase pp input dflags = + lookupHook runPhaseHook runPhase dflags pp input dflags + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. + +-- | Computes the next output filename after we run @next_phase@. +-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad +-- (which specifies all of the ambient information.) +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + liftIO $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc + +-- | Computes the next output filename for something in the compilation +-- pipeline. This is controlled by several variables: +-- +-- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This +-- is used to tell if we're in the last phase or not, because +-- in that case flags like @-o@ may be important. +-- 2. 'PipelineOutput': is this intended to be a 'Temporary' or +-- 'Persistent' build output? Temporary files just go in +-- a fresh temporary name. +-- 3. 'String': what was the basename of the original input file? +-- 4. 'DynFlags': the obvious thing +-- 5. 'Phase': the phase we want to determine the output filename of. +-- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're +-- compiling; this can be used to override the default output +-- of an object file. (TODO: do we actually need this?) +getOutputFilename + :: Phase -> PipelineOutput -> String + -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath +getOutputFilename stop_phase output basename dflags next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile <- output = case outputFile dflags of + Just f -> return f + Nothing -> + panic "SpecificFile: No filename" + | keep_this_output = persistent_fn + | Temporary lifetime <- output = newTempName dflags lifetime suffix + | otherwise = newTempName dflags TFL_CurrentModule + suffix + where + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = gopt Opt_KeepHcFiles dflags + keep_hscpp = gopt Opt_KeepHscppFiles dflags + keep_s = gopt Opt_KeepSFiles dflags + keep_bc = gopt Opt_KeepLlvmFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeForeign = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + As _ | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + HsPp _ | keep_hscpp -> True -- See #10869 + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | Just d <- odir = d </> persistent + | otherwise = persistent + + +-- | The fast LLVM Pipeline skips the mangler and assembler, +-- emitting object code directly from llc. +-- +-- slow: opt -> llc -> .s -> mangler -> as -> .o +-- fast: opt -> llc -> .o +-- +-- hidden flag: -ffast-llvm +-- +-- if keep-s-files is specified, we need to go through +-- the slow pipeline (Kavon Farvardin requested this). +fastLlvmPipeline :: DynFlags -> Bool +fastLlvmPipeline dflags + = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags + +-- | LLVM Options. These are flags to be passed to opt and llc, to ensure +-- consistency we list them in pairs, so that they form groups. +llvmOptions :: DynFlags + -> [(String, String)] -- ^ pairs of (opt, llc) arguments +llvmOptions dflags = + [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] + ++ [("-relocation-model=" ++ rmodel + ,"-relocation-model=" ++ rmodel) | not (null rmodel)] + ++ [("-stack-alignment=" ++ (show align) + ,"-stack-alignment=" ++ (show align)) | align > 0 ] + ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ] + + -- Additional llc flags + ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) + , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] + ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] + + where target = platformMisc_llvmTarget $ platformMisc dflags + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) + + -- Relocation models + rmodel | gopt Opt_PIC dflags = "pic" + | positionIndependent dflags = "pic" + | WayDyn `elem` ways dflags = "dynamic-no-pic" + | otherwise = "static" + + align :: Int + align = case platformArch (targetPlatform dflags) of + ArchX86_64 | isAvxEnabled dflags -> 32 + _ -> 0 + + attrs :: String + attrs = intercalate "," $ mattr + ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse2" | isSse2Enabled dflags ] + ++ ["+sse" | isSseEnabled dflags ] + ++ ["+avx512f" | isAvx512fEnabled dflags ] + ++ ["+avx2" | isAvx2Enabled dflags ] + ++ ["+avx" | isAvxEnabled dflags ] + ++ ["+avx512cd"| isAvx512cdEnabled dflags ] + ++ ["+avx512er"| isAvx512erEnabled dflags ] + ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + ++ ["+bmi" | isBmiEnabled dflags ] + ++ ["+bmi2" | isBmi2Enabled dflags ] + +-- ----------------------------------------------------------------------------- +-- | Each phase in the pipeline returns the next phase to execute, and the +-- name of the file in which the output was placed. +-- +-- We must do things dynamically this way, because we often don't know +-- what the rest of the phases will be until part-way through the +-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning +-- of a source file can change the latter stages of the pipeline from +-- taking the LLVM route to using the native code generator. +-- +runPhase :: PhasePlus -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (PhasePlus, -- next phase to run + FilePath) -- output filename + + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + + +------------------------------------------------------------------------------- +-- Unlit phase + +runPhase (RealPhase (Unlit sf)) input_fn dflags + = do + output_fn <- phaseOutputFilename (Cpp sf) + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + SysTools.Option "-h" + -- See Note [Don't normalise input filenames]. + , SysTools.Option $ escape input_fn + , SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ] + + liftIO $ SysTools.runUnlit dflags flags + + return (RealPhase (Cpp sf), output_fn) + where + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in + -- a SrcLoc is the same as the source filenaame, the two will + -- look bogusly different. See test: + -- libraries/hpc/tests/function/subdir/tough2.hs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + +------------------------------------------------------------------------------- +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary + +runPhase (RealPhase (Cpp sf)) input_fn dflags0 + = do + src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + + if not (xopt LangExt.Cpp dflags1) then do + -- we have to be careful to emit warnings only once. + unless (gopt Opt_Pp dflags1) $ + liftIO $ handleFlagWarnings dflags1 warns + + -- no need to preprocess CPP, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (HsPp sf), input_fn) + else do + output_fn <- phaseOutputFilename (HsPp sf) + liftIO $ doCpp dflags1 True{-raw-} + input_fn output_fn + -- re-read the pragmas now that we've preprocessed the file + -- See #2464,#3457 + src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + (dflags2, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + liftIO $ checkProcessArgsResult dflags2 unhandled_flags + unless (gopt Opt_Pp dflags2) $ + liftIO $ handleFlagWarnings dflags2 warns + -- the HsPp pass below will emit warnings + + setDynFlags dflags2 + + return (RealPhase (HsPp sf), output_fn) + +------------------------------------------------------------------------------- +-- HsPp phase + +runPhase (RealPhase (HsPp sf)) input_fn dflags + = do + if not (gopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (Hsc sf), input_fn) + else do + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + liftIO $ SysTools.runPp dflags + ( [ SysTools.Option orig_fn + , SysTools.Option input_fn + , SysTools.FileOption "" output_fn + ] + ) + + -- re-read pragmas now that we've parsed the file (see #3674) + src_opts <- liftIO $ getOptionsFromFile dflags output_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ handleFlagWarnings dflags1 warns + + return (RealPhase (Hsc sf), output_fn) + +----------------------------------------------------------------------------- +-- Hsc phase + +-- Compilation of a single module, in "legacy" mode (_not_ under +-- the direction of the compilation manager). +runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 + = do -- normal Hsc mode, not mkdependHS + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the include path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = takeDirectory basename + new_includes = addQuoteInclude paths [current_dir] + paths = includePaths dflags0 + dflags = dflags0 { includePaths = new_includes } + + setDynFlags dflags + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do + do + buf <- hGetStringBuffer input_fn + eimps <- getImports dflags buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors errs + Right (src_imps,imps,L _ mod_name) -> return + (Just buf, mod_name, imps, src_imps) + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + location <- getLocation src_flavour mod_name + + let o_file = ml_obj_file location -- The real object file + hi_file = ml_hi_file location + hie_file = ml_hie_file location + dest_file | writeInterfaceOnlyMode dflags + = hi_file + | otherwise + = o_file + + -- Figure out if the source has changed, for recompilation avoidance. + -- + -- Setting source_unchanged to True means that M.o (or M.hie) seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to False tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) + + source_unchanged <- liftIO $ + if not (isStopLn stop) + -- SourceModified unconditionally if + -- (a) recompilation checker is off, or + -- (b) we aren't going all the way to .o file (e.g. ghc -S) + then return SourceModified + -- Otherwise look at file modification dates + else do dest_file_mod <- sourceModified dest_file src_timestamp + hie_file_mod <- if gopt Opt_WriteHie dflags + then sourceModified hie_file + src_timestamp + else pure False + if dest_file_mod || hie_file_mod + then return SourceModified + else return SourceUnmodified + + PipeState{hsc_env=hsc_env'} <- getPipeState + + -- Tell the finder cache about this module + mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_parsed_mod = Nothing, + ms_iface_date = Nothing, + ms_hie_date = Nothing, + ms_textual_imps = imps, + ms_srcimps = src_imps } + + -- run the compiler! + let msg hsc_env _ what _ = oneShotMsg hsc_env what + (result, plugin_dflags) <- + liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' + mod_summary source_unchanged Nothing (1,1) + + -- In the rest of the pipeline use the dflags with plugin info + setDynFlags plugin_dflags + + return (HscOut src_flavour mod_name result, + panic "HscOut doesn't have an input filename") + +runPhase (HscOut src_flavour mod_name result) _ dflags = do + location <- getLocation src_flavour mod_name + setModLocation location + + let o_file = ml_obj_file location -- The real object file + hsc_lang = hscTarget dflags + next_phase = hscPostBackendPhase src_flavour hsc_lang + + case result of + HscNotGeneratingCode _ _ -> + return (RealPhase StopLn, + panic "No output filename from Hsc when no-code") + HscUpToDate _ _ -> + do liftIO $ touchObjectFile dflags o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't get Nothing) + -- but we touch it anyway, to keep 'make' happy (we think). + return (RealPhase StopLn, o_file) + HscUpdateBoot _ _ -> + do -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + liftIO $ touchObjectFile dflags o_file + return (RealPhase StopLn, o_file) + HscUpdateSig _ _ -> + do -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + PipeState{hsc_env=hsc_env'} <- getPipeState + let input_fn = expectJust "runPhase" (ml_hs_file location) + basename = dropExtension input_fn + liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name + return (RealPhase StopLn, o_file) + HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_mod_details = mod_details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags } + -> do output_fn <- phaseOutputFilename next_phase + + PipeState{hsc_env=hsc_env'} <- getPipeState + + (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $ + hscGenHardCode hsc_env' cgguts mod_location output_fn + + final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos)) + let final_mod_details = {-# SCC updateModDetailsCafInfos #-} + updateModDetailsCafInfos caf_infos mod_details + setIface final_iface final_mod_details + + -- See Note [Writing interface files] + let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo + liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location + + stub_o <- liftIO (mapM (compileStub hsc_env') mStub) + foreign_os <- liftIO $ + mapM (uncurry (compileForeign hsc_env')) foreign_files + setForeignOs (maybe [] return stub_o ++ foreign_os) + + return (RealPhase next_phase, outputFilename) + +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase (RealPhase CmmCpp) input_fn dflags + = do output_fn <- phaseOutputFilename Cmm + liftIO $ doCpp dflags False{-not raw-} + input_fn output_fn + return (RealPhase Cmm, output_fn) + +runPhase (RealPhase Cmm) input_fn dflags + = do let hsc_lang = hscTarget dflags + let next_phase = hscPostBackendPhase HsSrcFile hsc_lang + output_fn <- phaseOutputFilename next_phase + PipeState{hsc_env} <- getPipeState + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- Cc phase + +runPhase (RealPhase cc_phase) input_fn dflags + | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] + = do + let platform = targetPlatform dflags + hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + -- pass -D or -optP to preprocessor when compiling foreign C files + -- (#16737). Doing it in this way is simpler and also enable the C + -- compiler to perform preprocessing and parsing in a single pass, + -- but it may introduce inconsistency if a different pgm_P is specified. + let more_preprocessor_opts = concat + [ ["-Xpreprocessor", i] + | not hcc + , i <- getOpts dflags opt_P + ] + + let gcc_extra_viac_flags = extraGccViaCFlags dflags + let pic_c_flags = picCCOpts dflags + + let verbFlags = getVerbFlags dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + pkg_extra_cc_opts <- liftIO $ + if hcc + then return [] + else getPackageExtraCcOpts dflags pkgs + + framework_paths <- + if platformUsesFrameworks platform + then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs + let cmdlineFrameworkPaths = frameworkPaths dflags + return $ map ("-F"++) + (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + else return [] + + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] + + -- Decide next phase + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + + let + more_hcc_opts = + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if platformArch platform == ArchX86 && + not (gopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ + + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + ghcVersionH <- liftIO $ getGhcVersionPathName dflags + + liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( + [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + pic_c_flags + + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if platformOS platform == OSMinGW32 && + thisPackage dflags == baseUnitId + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. See #2872, commit + -- 5bd3072ac30216a505151601884ac88bf404c9f2 + ++ (if platformArch platform == ArchSPARC + then ["-mcpu=v9"] + else []) + + -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. + ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) + then ["-Wimplicit"] + else []) + + ++ (if hcc + then gcc_extra_viac_flags ++ more_hcc_opts + else []) + ++ verbFlags + ++ [ "-S" ] + ++ cc_opt + ++ [ "-include", ghcVersionH ] + ++ framework_paths + ++ include_paths + ++ more_preprocessor_opts + ++ pkg_extra_cc_opts + )) + + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- As, SpitAs phase : Assembler + +-- This is for calling the assembler on a regular assembly file +runPhase (RealPhase (As with_cpp)) input_fn dflags + = do + -- LLVM from version 3.0 onwards doesn't support the OS X system + -- assembler, so we use clang as the assembler instead. (#5636) + let as_prog | hscTarget dflags == HscLlvm && + platformOS (targetPlatform dflags) == OSDarwin + = SysTools.runClang + | otherwise = SysTools.runAs + + let cmdline_include_paths = includePaths dflags + let pic_c_flags = picCCOpts dflags + + next_phase <- maybeMergeForeign + output_fn <- phaseOutputFilename next_phase + + -- we create directories for the object file, because it + -- might be a hierarchical module. + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + + ccInfo <- liftIO $ getCompilerInfo dflags + let global_includes = [ SysTools.Option ("-I" ++ p) + | p <- includePathsGlobal cmdline_include_paths ] + let local_includes = [ SysTools.Option ("-iquote" ++ p) + | p <- includePathsQuote cmdline_include_paths ] + let runAssembler inputFilename outputFilename + = liftIO $ do + withAtomicRename outputFilename $ \temp_outputFilename -> do + as_prog + dflags + (local_includes ++ global_includes + -- See Note [-fPIC for assembler] + ++ map SysTools.Option pic_c_flags + -- See Note [Produce big objects on Windows] + ++ [ SysTools.Option "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) + ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [SysTools.Option "-Qunused-arguments"] + else []) + ++ [ SysTools.Option "-x" + , if with_cpp + then SysTools.Option "assembler-with-cpp" + else SysTools.Option "assembler" + , SysTools.Option "-c" + , SysTools.FileOption "" inputFilename + , SysTools.Option "-o" + , SysTools.FileOption "" temp_outputFilename + ]) + + liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") + runAssembler input_fn output_fn + + return (RealPhase next_phase, output_fn) + + +----------------------------------------------------------------------------- +-- LlvmOpt phase +runPhase (RealPhase LlvmOpt) input_fn dflags + = do + output_fn <- phaseOutputFilename LlvmLlc + + liftIO $ SysTools.runLlvmOpt dflags + ( optFlag + ++ defaultOptions ++ + [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn] + ) + + return (RealPhase LlvmLlc, output_fn) + where + -- we always (unless -optlo specified) run Opt since we rely on it to + -- fix up some pretty big deficiencies in the code we generate + optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] + llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of + Just passes -> passes + Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " + ++ "is missing passes for level " + ++ show optIdx) + + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null (getOpts dflags opt_lo) + then map SysTools.Option $ words llvmOpts + else [] + + defaultOptions = map SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions dflags) + +----------------------------------------------------------------------------- +-- LlvmLlc phase + +runPhase (RealPhase LlvmLlc) input_fn dflags + = do + next_phase <- if | fastLlvmPipeline dflags -> maybeMergeForeign + -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + | gopt Opt_NoLlvmMangler dflags -> return (As False) + | otherwise -> return LlvmMangle + + output_fn <- phaseOutputFilename next_phase + + liftIO $ SysTools.runLlvmLlc dflags + ( optFlag + ++ defaultOptions + ++ [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ) + + return (RealPhase next_phase, output_fn) + where + -- Note [Clamping of llc optimizations] + -- + -- See #13724 + -- + -- we clamp the llc optimization between [1,2]. This is because passing -O0 + -- to llc 3.9 or llc 4.0, the naive register allocator can fail with + -- + -- Error while trying to spill R1 from class GPR: Cannot scavenge register + -- without an emergency spill slot! + -- + -- Observed at least with target 'arm-unknown-linux-gnueabihf'. + -- + -- + -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile + -- rts/HeapStackCheck.cmm + -- + -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 + -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 + -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 + -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 + -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 + -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 + -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 + -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 + -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 + -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 + -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 + -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 + -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 + -- 13 llc 0x000000010195bf0b main + 491 + -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 + -- Stack dump: + -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. + -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' + -- + -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa + -- + llvmOpts = case optLevel dflags of + 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. + 1 -> "-O1" + _ -> "-O2" + + optFlag = if null (getOpts dflags opt_lc) + then map SysTools.Option $ words llvmOpts + else [] + + defaultOptions = map SysTools.Option . concatMap words . snd + $ unzip (llvmOptions dflags) + + +----------------------------------------------------------------------------- +-- LlvmMangle phase + +runPhase (RealPhase LlvmMangle) input_fn dflags + = do + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + liftIO $ llvmFixupAsm dflags input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects + +runPhase (RealPhase MergeForeign) input_fn dflags + = do + PipeState{foreign_os} <- getPipeState + output_fn <- phaseOutputFilename StopLn + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + if null foreign_os + then panic "runPhase(MergeForeign): no foreign objects" + else do + liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn + return (RealPhase StopLn, output_fn) + +-- warning suppression +runPhase (RealPhase other) _input_fn _dflags = + panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeForeign :: CompPipeline Phase +maybeMergeForeign + = do + PipeState{foreign_os} <- getPipeState + if null foreign_os then return StopLn else return MergeForeign + +getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation +getLocation src_flavour mod_name = do + dflags <- getDynFlags + + PipeEnv{ src_basename=basename, + src_suffix=suff } <- getPipeEnv + PipeState { maybe_loc=maybe_loc} <- getPipeState + case maybe_loc of + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames. If we already have a ModLocation + -- then simply update the extensions of the interface and object + -- files to match the DynFlags, otherwise use the logic in Finder. + Just l -> return $ l + { ml_hs_file = Just $ basename <.> suff + , ml_hi_file = ml_hi_file l -<.> hiSuf dflags + , ml_obj_file = ml_obj_file l -<.> objectSuf dflags + } + _ -> do + location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + + -- Boot-ify it if necessary + let location2 + | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile + -- above + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file = ofile } + | otherwise = location3 + return location4 + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [InstalledUnitId] +getHCFilePackages filename = + Exception.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToInstalledUnitId (words rest)) + _other -> + return [] + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +{- +Note [-Xlinker -rpath vs -Wl,-rpath] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-Wl takes a comma-separated list of options which in the case of +-Wl,-rpath -Wl,some,path,with,commas parses the path with commas +as separate options. +Buck, the build system, produces paths with commas in them. + +-Xlinker doesn't have this disadvantage and as far as I can tell +it is supported by both gcc and clang. Anecdotally nvcc supports +-Xlinker, but not -Wl. +-} + +linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary = linkBinary' False + +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary' staticLink dflags o_files dep_packages = do + let platform = targetPlatform dflags + toolSettings' = toolSettings dflags + verbFlags = getVerbFlags dflags + output_fn = exeFileName staticLink dflags + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d </> output_fn) + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + WayDyn `elem` ways dflags + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "$ORIGIN" </> + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if gopt Opt_RPath dflags + then ["-Xlinker", "-rpath", "-Xlinker", libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l<some + -- dir> as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Xlinker", "-rpath-link", "-Xlinker", l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + WayDyn `elem` ways dflags && + gopt Opt_RPath dflags + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "@loader_path" </> + (l `makeRelativeTo` full_output_fn) + else l + in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] + | otherwise = ["-L" ++ l] + + pkg_lib_path_opts <- + if gopt Opt_SingleLibFolder dflags + then do + libs <- getLibs dflags dep_packages + tmpDir <- newTempDir dflags + sequence_ [ copyFile lib (tmpDir </> basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + + let + dead_strip + | gopt Opt_WholeArchiveHsLibs dflags = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages + + let + (pre_hs_libs, post_hs_libs) + | gopt Opt_WholeArchiveHsLibs dflags + = if platformOS platform == OSDarwin + then (["-Wl,-all_load"], []) + -- OS X does not have a flag to turn off -all_load + else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) + | otherwise + = ([],[]) + + pkg_link_opts <- do + (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages + return $ if staticLink + then package_hs_libs -- If building an executable really means making a static + -- library (e.g. iOS), then we only keep the -l options for + -- HS packages, because libtool doesn't accept other options. + -- In the case of iOS these need to be added by hand to the + -- final link in Xcode. + else other_flags ++ dead_strip + ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs + ++ extra_libs + -- -Wl,-u,<sym> contained in other_flags + -- needs to be put before -l<package>, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages + let framework_opts = getFrameworkOpts dflags platform + + -- probably _stub.o files + let extra_ld_inputs = ldInputs dflags + + rc_objs <- maybeCreateManifest dflags output_fn + + let link = if staticLink + then SysTools.runLibtool + else SysTools.runLink + link dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts + ++ map SysTools.Option ( + [] + + -- See Note [No PIE when linking] + ++ picCCOpts dflags + + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && + not staticLink && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchARM {} -> True + ArchARM64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- '-Wl,-read_only_relocs,suppress' + -- ld gives loads of warnings like: + -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure + -- when linking any program. We're not sure + -- whether this is something we ought to fix, but + -- for now this flags silences them. + ++ (if platformOS platform == OSDarwin && + platformArch platform == ArchX86 && + not staticLink + then ["-Wl,-read_only_relocs,suppress"] + else []) + + ++ (if toolSettings_ldIsGnuLd toolSettings' && + not (gopt Opt_WholeArchiveHsLibs dflags) + then ["-Wl,--gc-sections"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj:noteLinkObjs + ++ pkg_link_opts + ++ pkg_framework_opts + ++ (if platformOS platform == OSDarwin + then [ "-Wl,-dead_strip_dylibs" ] + else []) + )) + +exeFileName :: Bool -> DynFlags -> FilePath +exeFileName staticLink dflags + | Just s <- outputFile dflags = + case platformOS (targetPlatform dflags) of + OSMinGW32 -> s <?.> "exe" + _ -> if staticLink + then s <?.> "a" + else s + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.exe" + else if staticLink + then "liba.a" + else "a.out" + where s <?.> ext | null (takeExtension s) = s <.> ext + | otherwise = s + +maybeCreateManifest + :: DynFlags + -> FilePath -- filename of executable + -> IO [FilePath] -- extra objects to embed, maybe +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + gopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ + " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ + " <assemblyIdentity version=\"1.0.0.0\"\n"++ + " processorArchitecture=\"X86\"\n"++ + " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ + " type=\"win32\"/>\n\n"++ + " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ + " <security>\n"++ + " <requestedPrivileges>\n"++ + " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ + " </requestedPrivileges>\n"++ + " </security>\n"++ + " </trustInfo>\n"++ + "</assembly>\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (gopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags TFL_CurrentModule "rc" + rc_obj_filename <- + newTempName dflags TFL_GhcSession (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] + | otherwise = return [] + + +linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkDynLibCheck dflags o_files dep_packages + = do + when (haveRtsOptsFlags dflags) $ do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + linkDynLib dflags o_files dep_packages + +-- | Linking a static lib will not really link anything. It will merely produce +-- a static archive of all dependent static libraries. The resulting library +-- will still need to be linked with any remaining link flags. +linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkStaticLib dflags o_files dep_packages = do + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + modules = o_files ++ extra_ld_inputs + output_fn = exeFileName True dflags + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d </> output_fn) + output_exists <- doesFileExist full_output_fn + (when output_exists) $ removeFile full_output_fn + + pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages + archives <- concatMapM (collectArchives dflags) pkg_cfgs + + ar <- foldl mappend + <$> (Archive <$> mapM loadObj modules) + <*> mapM loadAr archives + + if toolSettings_ldIsGnuLd (toolSettings dflags) + then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar + else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar + + -- run ranlib over the archive. write*Ar does *not* create the symbol index. + runRanlib dflags [SysTools.FileOption "" output_fn] + +-- ----------------------------------------------------------------------------- +-- Running CPP + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args + | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args) + + let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags + targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", + "-D" ++ targetOS ++ "_HOST_OS", + "-D" ++ targetArch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitPackages (pkgState dflags) + pkgs = catMaybes (map (lookupUnit dflags) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = packageVersion pkg + pkgname = map fixchar (packageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +{- +Note [Produce big objects on Windows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Windows Portable Executable object format has a limit of 32k sections, which +we tend to blow through pretty easily. Thankfully, there is a "big object" +extension, which raises this limit to 2^32. However, it must be explicitly +enabled in the toolchain: + + * the assembler accepts the -mbig-obj flag, which causes it to produce a + bigobj-enabled COFF object. + + * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name + suggests, this tells the linker to produce a bigobj-enabled COFF object, no a + PE executable. + +We must enable bigobj output in a few places: + + * When merging object files (GHC.Driver.Pipeline.joinObjectFiles) + + * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) + +Unfortunately the big object format is not supported on 32-bit targets so +none of this can be used in that case. +-} + +joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles dflags o_files output_fn = do + let toolSettings' = toolSettings dflags + ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' + osInfo = platformOS (targetPlatform dflags) + ld_r args cc = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-Wl,-r" + ] + -- See Note [No PIE while linking] in DynFlags + ++ (if toolSettings_ccSupportsNoPie toolSettings' + then [SysTools.Option "-no-pie"] + else []) + + ++ (if any (cc ==) [Clang, AppleClang, AppleClang51] + then [] + else [SysTools.Option "-nodefaultlibs"]) + ++ (if osInfo == OSFreeBSD + then [SysTools.Option "-L/usr/lib"] + else []) + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) + `elem` [ArchSPARC, ArchSPARC64] + && ldIsGnuLd + then [SysTools.Option "-Wl,-no-relax"] + else []) + -- See Note [Produce big objects on Windows] + ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64" + | OSMinGW32 == osInfo + , not $ target32Bit (targetPlatform dflags) + ] + ++ map SysTools.Option ld_build_id + ++ [ SysTools.Option "-o", + SysTools.FileOption "" output_fn ] + ++ args) + + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["-Wl,--build-id=none"] + | otherwise = [] + + ccInfo <- getCompilerInfo dflags + if ldIsGnuLd + then do + script <- newTempName dflags TFL_CurrentModule "ldscript" + cwd <- getCurrentDirectory + let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" + ld_r [SysTools.FileOption "" script] ccInfo + else if toolSettings_ldSupportsFilelist toolSettings' + then do + filelist <- newTempName dflags TFL_CurrentModule "filelist" + writeFile filelist $ unlines o_files + ld_r [SysTools.Option "-Wl,-filelist", + SysTools.FileOption "-Wl," filelist] ccInfo + else do + ld_r (map (SysTools.FileOption "") o_files) ccInfo + +-- ----------------------------------------------------------------------------- +-- Misc. + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + HscNothing == hscTarget dflags + +-- | Figure out if a source file was modified after an output file (or if we +-- anyways need to consider the source file modified since the output is gone). +sourceModified :: FilePath -- ^ destination file we are looking for + -> UTCTime -- ^ last time of modification of source file + -> IO Bool -- ^ do we need to regenerate the output? +sourceModified dest_file src_timestamp = do + dest_file_exists <- doesFileExist dest_file + if not dest_file_exists + then return True -- Need to recompile + else do t2 <- getModificationUTCTime dest_file + return (t2 <= src_timestamp) + +-- | What phase to run after one of the backend code generators has run +hscPostBackendPhase :: HscSource -> HscTarget -> Phase +hscPostBackendPhase HsBootFile _ = StopLn +hscPostBackendPhase HsigFile _ = StopLn +hscPostBackendPhase _ hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm -> As False + HscLlvm -> LlvmOpt + HscNothing -> StopLn + HscInterpreted -> StopLn + +touchObjectFile :: DynFlags -> FilePath -> IO () +touchObjectFile dflags path = do + createDirectoryIfMissing True $ takeDirectory path + SysTools.touch dflags "Touching object file" path + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map (</> "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +-- Note [-fPIC for assembler] +-- When compiling .c source file GHC's driver pipeline basically +-- does the following two things: +-- 1. ${CC} -S 'PIC_CFLAGS' source.c +-- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S +-- +-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? +-- Because on some architectures (at least sparc32) assembler also chooses +-- the relocation type! +-- Consider the following C module: +-- +-- /* pic-sample.c */ +-- int v; +-- void set_v (int n) { v = n; } +-- int get_v (void) { return v; } +-- +-- $ gcc -S -fPIC pic-sample.c +-- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary +-- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary +-- +-- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od +-- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od +-- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od +-- +-- Most of architectures won't show any difference in this test, but on sparc32 +-- the following assembly snippet: +-- +-- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 +-- +-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: +-- +-- 3c: 2f 00 00 00 sethi %hi(0), %l7 +-- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 +-- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 + +{- Note [Don't normalise input filenames] + +Summary + We used to normalise input filenames when starting the unlit phase. This + broke hpc in `--make` mode with imported literate modules (#2991). + +Introduction + 1) --main + When compiling a module with --main, GHC scans its imports to find out which + other modules it needs to compile too. It turns out that there is a small + difference between saying `ghc --make A.hs`, when `A` imports `B`, and + specifying both modules on the command line with `ghc --make A.hs B.hs`. In + the former case, the filename for B is inferred to be './B.hs' instead of + 'B.hs'. + + 2) unlit + When GHC compiles a literate haskell file, the source code first needs to go + through unlit, which turns it into normal Haskell source code. At the start + of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the + option `-h` and the name of the original file. We used to normalise this + filename using System.FilePath.normalise, which among other things removes + an initial './'. unlit then uses that filename in #line directives that it + inserts in the transformed source code. + + 3) SrcSpan + A SrcSpan represents a portion of a source code file. It has fields + linenumber, start column, end column, and also a reference to the file it + originated from. The SrcSpans for a literate haskell file refer to the + filename that was passed to unlit -h. + + 4) -fhpc + At some point during compilation with -fhpc, in the function + `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `SrcSpan` refers to with the name of the file we are currently compiling. + For some reason I don't yet understand, they can sometimes legitimally be + different, and then hpc ignores that SrcSpan. + +Problem + When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate + module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the + start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). + Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are + still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), + doesn't include ticks for B, and we have unhappy customers (#2991). + +Solution + Do not normalise `input_fn` when starting the unlit phase. + +Alternative solution + Another option would be to not compare the two filenames on equality, but to + use System.FilePath.equalFilePath. That function first normalises its + arguments. The problem is that by the time we need to do the comparison, the + filenames have been turned into FastStrings, probably for performance + reasons, so System.FilePath.equalFilePath can not be used directly. + +Archeology + The call to `normalise` was added in a commit called "Fix slash + direction on Windows with the new filePath code" (c9b6b5e8). The problem + that commit was addressing has since been solved in a different manner, in a + commit called "Fix the filename passed to unlit" (1eedbc6b). So the + `normalise` is no longer necessary. +-} diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs new file mode 100644 index 0000000000..5831f923ea --- /dev/null +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | The CompPipeline monad and associated ops +-- +-- Defined in separate module so that it can safely be imported from Hooks +module GHC.Driver.Pipeline.Monad ( + CompPipeline(..), evalP + , PhasePlus(..) + , PipeEnv(..), PipeState(..), PipelineOutput(..) + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface + , pipeStateDynFlags, pipeStateModIface + ) where + +import GhcPrelude + +import MonadUtils +import Outputable +import GHC.Driver.Session +import GHC.Driver.Phases +import GHC.Driver.Types +import Module +import FileCleanup (TempFileLifetime) + +import Control.Monad + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + deriving (Functor) + +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) +evalP (P f) env st = f env st + +instance Applicative CompPipeline where + pure a = P $ \_env state -> return (state, a) + (<*>) = ap + +instance Monad CompPipeline where + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +instance MonadIO CompPipeline where + liftIO m = P $ \_env state -> do a <- m; return (state, a) + +data PhasePlus = RealPhase Phase + | HscOut HscSource ModuleName HscStatus + +instance Outputable PhasePlus where + ppr (RealPhase p) = ppr p + ppr (HscOut {}) = text "HscOut" + +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + foreign_os :: [FilePath], + -- ^ additional object files resulting from compiling foreign + -- code. They come from two sources: foreign stubs, and + -- add{C,Cxx,Objc,Objcxx}File from template haskell + iface :: Maybe (ModIface, ModDetails) + -- ^ Interface generated by HscOut phase. Only available after the + -- phase runs. + } + +pipeStateDynFlags :: PipeState -> DynFlags +pipeStateDynFlags = hsc_dflags . hsc_env + +pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails) +pipeStateModIface = iface + +data PipelineOutput + = Temporary TempFileLifetime + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + deriving Show + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setForeignOs :: [FilePath] -> CompPipeline () +setForeignOs os = P $ \_env state -> + return (state{ foreign_os = os }, ()) + +setIface :: ModIface -> ModDetails -> CompPipeline () +setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ()) diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs new file mode 100644 index 0000000000..baa27a0b36 --- /dev/null +++ b/compiler/GHC/Driver/Plugins.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +-- | Definitions for writing /plugins/ for GHC. Plugins can hook into +-- several areas of the compiler. See the 'Plugin' type. These plugins +-- include type-checker plugins, source plugins, and core-to-core plugins. + +module GHC.Driver.Plugins ( + -- * Plugins + Plugin(..) + , defaultPlugin + , CommandLineOption + -- ** Recompilation checking + , purePlugin, impurePlugin, flagRecompile + , PluginRecompile(..) + + -- * Plugin types + -- ** Frontend plugins + , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction + -- ** Core plugins + -- | Core plugins allow plugins to register as a Core-to-Core pass. + , CorePlugin + -- ** Typechecker plugins + -- | Typechecker plugins allow plugins to provide evidence to the + -- typechecker. + , TcPlugin + -- ** Source plugins + -- | GHC offers a number of points where plugins can access and modify its + -- front-end (\"source\") representation. These include: + -- + -- - access to the parser result with 'parsedResultAction' + -- - access to the renamed AST with 'renamedResultAction' + -- - access to the typechecked AST with 'typeCheckResultAction' + -- - access to the Template Haskell splices with 'spliceRunAction' + -- - access to loaded interface files with 'interfaceLoadAction' + -- + , keepRenamedSource + -- ** Hole fit plugins + -- | hole fit plugins allow plugins to change the behavior of valid hole + -- fit suggestions + , HoleFitPluginR + + -- * Internal + , PluginWithArgs(..), plugins, pluginRecompile' + , LoadedPlugin(..), lpModuleName + , StaticPlugin(..) + , mapPlugins, withPlugins, withPlugins_ + ) where + +import GhcPrelude + +import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) +import qualified TcRnTypes +import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) +import TcHoleFitTypes ( HoleFitPluginR ) +import GHC.Hs +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Driver.Monad +import GHC.Driver.Phases +import Module ( ModuleName, Module(moduleName)) +import Fingerprint +import Data.List (sort) +import Outputable (Outputable(..), text, (<+>)) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup + +import Control.Monad + +-- | Command line options gathered from the -PModule.Name:stuff syntax +-- are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatibility when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in +-- the future. +data Plugin = Plugin { + installCoreToDos :: CorePlugin + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify the + -- pipeline in a nondeterministic order. + , tcPlugin :: TcPlugin + -- ^ An optional typechecker plugin, which may modify the + -- behaviour of the constraint solver. + , holeFitPlugin :: HoleFitPlugin + -- ^ An optional plugin to handle hole fits, which may re-order + -- or change the list of valid hole fits and refinement hole fits. + , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags + -- ^ An optional plugin to update 'DynFlags', right after + -- plugin loading. This can be used to register hooks + -- or tweak any field of 'DynFlags' before doing + -- actual work on a module. + -- + -- @since 8.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile + -- ^ Specify how the plugin should affect recompilation. + , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule + -> Hsc HsParsedModule + -- ^ Modify the module when it is parsed. This is called by + -- GHC.Driver.Main when the parsing is successful. + , renamedResultAction :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) + -- ^ Modify each group after it is renamed. This is called after each + -- `HsGroup` has been renamed. + , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv + -> TcM TcGblEnv + -- ^ Modify the module when it is type checked. This is called at the + -- very end of typechecking. + , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc + -> TcM (LHsExpr GhcTc) + -- ^ Modify the TH splice or quasiqoute before it is run. + , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface + -> IfM lcl ModIface + -- ^ Modify an interface that have been loaded. This is called by + -- GHC.Iface.Load when an interface is successfully loaded. Not applied to + -- the loading of the plugin interface. Tools that rely on information from + -- modules other than the currently compiled one should implement this + -- function. + } + +-- Note [Source plugins] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `Plugin` datatype have been extended by fields that allow access to the +-- different inner representations that are generated during the compilation +-- process. These fields are `parsedResultAction`, `renamedResultAction`, +-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. +-- +-- The main purpose of these plugins is to help tool developers. They allow +-- development tools to extract the information about the source code of a big +-- Haskell project during the normal build procedure. In this case the plugin +-- acts as the tools access point to the compiler that can be controlled by +-- compiler flags. This is important because the manipulation of compiler flags +-- is supported by most build environment. +-- +-- For the full discussion, check the full proposal at: +-- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal + +data PluginWithArgs = PluginWithArgs + { paPlugin :: Plugin + -- ^ the actual callable plugin + , paArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } + +-- | A plugin with its arguments. The result of loading the plugin. +data LoadedPlugin = LoadedPlugin + { lpPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + , lpModule :: ModIface + -- ^ the module containing the plugin + } + +-- | A static plugin with its arguments. For registering compiled-in plugins +-- through the GHC API. +data StaticPlugin = StaticPlugin + { spPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + } + +lpModuleName :: LoadedPlugin -> ModuleName +lpModuleName = moduleName . mi_module . lpModule + +pluginRecompile' :: PluginWithArgs -> IO PluginRecompile +pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args + +data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint + +instance Outputable PluginRecompile where + ppr ForceRecompile = text "ForceRecompile" + ppr NoForceRecompile = text "NoForceRecompile" + ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp + +instance Semigroup PluginRecompile where + ForceRecompile <> _ = ForceRecompile + NoForceRecompile <> r = r + MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp + MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) + MaybeRecompile _fp <> ForceRecompile = ForceRecompile + +instance Monoid PluginRecompile where + mempty = NoForceRecompile + +type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin +type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR + +purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile +purePlugin _args = return NoForceRecompile + +impurePlugin _args = return ForceRecompile + +flagRecompile = + return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort + +-- | Default plugin: does nothing at all, except for marking that safe +-- inference has failed unless @-fplugin-trustworthy@ is passed. For +-- compatibility reason you should base all your plugin definitions on this +-- default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + , tcPlugin = const Nothing + , holeFitPlugin = const Nothing + , dynflagsPlugin = const return + , pluginRecompile = impurePlugin + , renamedResultAction = \_ env grp -> return (env, grp) + , parsedResultAction = \_ _ -> return + , typeCheckResultAction = \_ _ -> return + , spliceRunAction = \_ -> return + , interfaceLoadAction = \_ -> return + } + + +-- | A renamer plugin which mades the renamed source available in +-- a typechecker plugin. +keepRenamedSource :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) +keepRenamedSource _ gbl_env group = + return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) + , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) + where + update_exports Nothing = Just [] + update_exports m = m + + update Nothing = Just emptyRnGroup + update m = m + + +type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a +type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () + +plugins :: DynFlags -> [PluginWithArgs] +plugins df = + map lpPlugin (cachedPlugins df) ++ + map spPlugin (staticPlugins df) + +-- | Perform an operation by using all of the plugins in turn. +withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a +withPlugins df transformation input = foldM go input (plugins df) + where + go arg (PluginWithArgs p opts) = transformation p opts arg + +mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a] +mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df) + +-- | Perform a constant operation by using all of the plugins in turn. +withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m () +withPlugins_ df transformation input + = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) + (plugins df) + +type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () +data FrontendPlugin = FrontendPlugin { + frontend :: FrontendPluginAction + } +defaultFrontendPlugin :: FrontendPlugin +defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } diff --git a/compiler/GHC/Driver/Plugins.hs-boot b/compiler/GHC/Driver/Plugins.hs-boot new file mode 100644 index 0000000000..41a0c115d2 --- /dev/null +++ b/compiler/GHC/Driver/Plugins.hs-boot @@ -0,0 +1,10 @@ +-- The plugins datatype is stored in DynFlags, so it needs to be +-- exposed without importing all of its implementation. +module GHC.Driver.Plugins where + +import GhcPrelude () + +data Plugin + +data LoadedPlugin +data StaticPlugin diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs new file mode 100644 index 0000000000..4eb9ab2597 --- /dev/null +++ b/compiler/GHC/Driver/Session.hs @@ -0,0 +1,5939 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} + +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Driver.Session ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), WarnReason(..), + Language(..), + PlatformConstants(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), + ProfAuto(..), + glasgowExtsFlags, + warningGroups, warningHierarchies, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + lang_set, + whenGeneratingDynamicToo, ifGeneratingDynamicToo, + whenCannotGenerateDynamicToo, + dynamicTooMkDynamicDynFlags, + dynamicOutputFile, + DynFlags(..), + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fLangFlags, xFlags, + wWarningFlags, + dynFlagDependencies, + makeDynFlagsConsistent, + positionIndependent, + optimisationFlags, + setFlagsFromEnvFile, + + Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, + wayGeneralFlags, wayUnsetGeneralFlags, + + thisPackage, thisComponentId, thisUnitIdInsts, + + -- ** Log output + putLogMsg, + + -- ** Safe Haskell + SafeHaskellMode(..), + safeHaskellOn, safeHaskellModeEnabled, + safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** LLVM Targets + LlvmTarget(..), LlvmConfig(..), + + -- ** System tool settings and locations + Settings(..), + sProgramName, + sProjectVersion, + sGhcUsagePath, + sGhciUsagePath, + sToolDir, + sTopDir, + sTmpDir, + sGlobalPackageDatabasePath, + sLdSupportsCompactUnwind, + sLdSupportsBuildId, + sLdSupportsFilelist, + sLdIsGnuLd, + sGccSupportsNoPie, + sPgm_L, + sPgm_P, + sPgm_F, + sPgm_c, + sPgm_a, + sPgm_l, + sPgm_dll, + sPgm_T, + sPgm_windres, + sPgm_libtool, + sPgm_ar, + sPgm_ranlib, + sPgm_lo, + sPgm_lc, + sPgm_lcc, + sPgm_i, + sOpt_L, + sOpt_P, + sOpt_P_fingerprint, + sOpt_F, + sOpt_c, + sOpt_cxx, + sOpt_a, + sOpt_l, + sOpt_windres, + sOpt_lo, + sOpt_lc, + sOpt_lcc, + sOpt_i, + sExtraGccViaCFlags, + sTargetPlatformString, + sIntegerLibrary, + sIntegerLibraryType, + sGhcWithInterpreter, + sGhcWithNativeCodeGen, + sGhcWithSMP, + sGhcRTSWays, + sTablesNextToCode, + sLeadingUnderscore, + sLibFFI, + sGhcThreaded, + sGhcDebugged, + sGhcRtsWithLibdw, + IntegerLibrary(..), + GhcNameVersion(..), + FileSettings(..), + PlatformMisc(..), + settings, + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, tmpDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, + pgm_lcc, pgm_i, + opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i, + opt_P_signature, + opt_windres, opt_lo, opt_lc, opt_lcc, + tablesNextToCode, + + -- ** Manipulating DynFlags + addPluginModuleName, + defaultDynFlags, -- Settings -> DynFlags + defaultWays, + interpWays, + interpreterProfiled, interpreterDynamic, + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultLogAction, + defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, + defaultFlushOut, + defaultFlushErr, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setUnitId, + canonicalizeHomeModule, + canonicalizeModuleIfHome, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags + allNonDeprecatedFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + + rtsIsProfiled, + dynamicGhc, + +#include "GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wORD_SIZE_IN_BITS, + wordAlignment, + tAG_MASK, + mAX_PTR_TAG, + tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, + + unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSseEnabled, + isSse2Enabled, + isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + + -- * Linker/compiler information + LinkerInfo(..), + CompilerInfo(..), + + -- * File cleanup + FilesToClean(..), emptyFilesToClean, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + + -- * SDoc + initSDocContext, + + -- * Make use of the Cmm CFG + CfgWeights(..), backendMaintainsCfg + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Platform +import GHC.UniqueSubdir (uniqueSubdir) +import PlatformConstants +import Module +import {-# SOURCE #-} GHC.Driver.Plugins +import {-# SOURCE #-} GHC.Driver.Hooks +import {-# SOURCE #-} PrelNames ( mAIN ) +import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase) +import GHC.Driver.Phases ( Phase(..), phaseInputExt ) +import Config +import CliOption +import GHC.Driver.CmdLine hiding (WarnReason(..)) +import qualified GHC.Driver.CmdLine as Cmd +import Constants +import GhcNameVersion +import Panic +import qualified PprColour as Col +import Util +import Maybes +import MonadUtils +import qualified Pretty +import SrcLoc +import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) +import FastString +import Fingerprint +import FileSettings +import Outputable +import Settings +import ToolSettings + +import Foreign.C ( CInt(..) ) +import System.IO.Unsafe ( unsafeDupablePerformIO ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn + , getCaretDiagnostic, DumpAction, TraceAction + , defaultDumpAction, defaultTraceAction ) +import Json +import SysTools.Terminal ( stderrSupportsAnsiColors ) +import SysTools.BaseDir ( expandToolDir, expandTopDir ) + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except + +import Data.Ord +import Data.Bits +import Data.Char +import Data.Int +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import System.FilePath +import System.Directory +import System.Environment (lookupEnv) +import System.IO +import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import EnumSet (EnumSet) +import qualified EnumSet + +import GHC.Foreign (withCString, peekCString) +import qualified GHC.LanguageExtensions as LangExt + +#if GHC_STAGE >= 2 +-- used by SHARED_GLOBAL_VAR +import Foreign (Ptr) +#endif + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- described in the User's Guide. Please update the flag description in the +-- users guide (docs/users_guide) whenever you add or change a flag. + +-- Note [Supporting CLI completion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- Note [Adding a language extension] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a few steps to adding (or removing) a language extension, +-- +-- * Adding the extension to GHC.LanguageExtensions +-- +-- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +-- is the canonical list of language extensions known by GHC. +-- +-- * Adding a flag to DynFlags.xFlags +-- +-- This is fairly self-explanatory. The name should be concise, memorable, +-- and consistent with any previous implementations of the similar idea in +-- other Haskell compilers. +-- +-- * Adding the flag to the documentation +-- +-- This is the same as any other flag. See +-- Note [Updating flag description in the User's Guide] +-- +-- * Adding the flag to Cabal +-- +-- The Cabal library has its own list of all language extensions supported +-- by all major compilers. This is the list that user code being uploaded +-- to Hackage is checked against to ensure language extension validity. +-- Consequently, it is very important that this list remains up-to-date. +-- +-- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) +-- whose job it is to ensure these GHC's extensions are consistent with +-- Cabal. +-- +-- The recommended workflow is, +-- +-- 1. Temporarily add your new language extension to the +-- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't +-- break while Cabal is updated. +-- +-- 2. After your GHC change is accepted, submit a Cabal pull request adding +-- your new extension to Cabal's list (found in +-- Cabal/Language/Haskell/Extension.hs). +-- +-- 3. After your Cabal change is accepted, let the GHC developers know so +-- they can update the Cabal submodule and remove the extensions from +-- expectedGhcOnlyExtensions. +-- +-- * Adding the flag to the GHC Wiki +-- +-- There is a change log tracking language extension additions and removals +-- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history +-- +-- See #4437 and #8176. + +-- ----------------------------------------------------------------------------- +-- DynFlags + +data DumpFlag +-- See Note [Updating flag description in the User's Guide] + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_from_stg + | Opt_D_dump_cmm_raw + | Opt_D_dump_cmm_verbose_by_proc + -- All of the cmm subflags (there are a lot!) automatically + -- enabled if you run -ddump-cmm-verbose-by-proc + -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_verbose + -- same as -ddump-cmm-verbose-by-proc but writes each stage + -- to a separate file (if used with -ddump-to-file) + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_switch + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_caf + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + -- end cmm subflags + | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | Opt_D_dump_core_stats + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_ds_preopt + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_parsed_ast + | Opt_D_dump_rn + | Opt_D_dump_rn_ast + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg -- CoreToStg output + | Opt_D_dump_stg_unarised -- STG after unarise + | Opt_D_dump_stg_final -- STG after stg2stg + | Opt_D_dump_call_arity + | Opt_D_dump_exitify + | Opt_D_dump_stranal + | Opt_D_dump_str_signatures + | Opt_D_dump_cpranal + | Opt_D_dump_cpr_signatures + | Opt_D_dump_tc + | Opt_D_dump_tc_ast + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker + | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map + | Opt_D_dump_timings + | Opt_D_dump_view_pattern_commoning + | Opt_D_verbose_core2core + | Opt_D_dump_debug + | Opt_D_dump_json + | Opt_D_ppr_debug + | Opt_D_no_debug_output + deriving (Eq, Show, Enum) + + +-- | Enumerates the simple on-or-off dynamic flags +data GeneralFlag +-- See Note [Updating flag description in the User's Guide] + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_D_faststring_stats + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag + | Opt_NoTypeableBinds + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_ShowWarnGroups -- Show the group a warning belongs to + | Opt_HideSourcePaths -- Hide module source/object paths + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintExplicitRuntimeReps + | Opt_PrintEqualityRelations + | Opt_PrintAxiomIncomps + | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms + | Opt_PrintPotentialInstances + | Opt_PrintTypecheckerElaboration + + -- optimisation opts + | Opt_CallArity + | Opt_Exitification + | Opt_Strictness + | Opt_LateDmdAnal -- #6087 + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_LateSpecialise + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_CrossModuleSpecialise + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_StgCSE + | Opt_StgLiftLams + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_SpecConstrKeen + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_CaseFolding -- Constant folding through case-expressions + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infrastructure for improving AA (hidden flag) + | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) + | Opt_IrrefutableTuples + | Opt_CmmSink + | Opt_CmmElimCommonBlocks + | Opt_AsmShortcutting + | Opt_OmitYields + | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas + | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | Opt_CprAnal + | Opt_WorkerWrapper + | Opt_SolveConstantDicts + | Opt_AlignmentSanitisation + | Opt_CatchBottoms + | Opt_NumConstantFolding + + -- PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining + + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code + | Opt_WriteHie -- generate .hie files + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_NoHsMain + | Opt_SplitSections + | Opt_StgStats + | Opt_HideAllPackages + | Opt_HideAllPluginPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_GhciHistory + | Opt_GhciLeakCheck + | Opt_ValidateHie + | Opt_LocalGhciHistory + | Opt_NoIt + | Opt_HelpfulErrors + | Opt_DeferTypeErrors + | Opt_DeferTypedHoles + | Opt_DeferOutOfScopeVariables + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs + | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_Hpc + | Opt_FlatCache + | Opt_ExternalInterpreter + | Opt_OptimalApplicativeDo + | Opt_VersionMacros + | Opt_WholeArchiveHsLibs + -- copy all libs into a single folder prior to linking binaries + -- this should elivate the excessive command line limit restrictions + -- on windows, by only requiring a single -L argument instead of + -- one for each dependency. At the time of this writing, gcc + -- forwards all -L flags to the collect2 command without using a + -- response file and as such breaking apart. + | Opt_SingleLibFolder + | Opt_KeepCAFs + | Opt_KeepGoing + | Opt_ByteCode + + -- output style opts + | Opt_ErrorSpans -- Include full span info in error messages, + -- instead of just the start position. + | Opt_DeferDiagnostics + | Opt_DiagnosticsShowCaret -- Show snippets of offending code + | Opt_PprCaseAsLet + | Opt_PprShowTicks + | Opt_ShowHoleConstraints + -- Options relating to the display of valid hole fits + -- when generating an error message for a typed hole + -- See Note [Valid hole fits include] in TcHoleErrors.hs + | Opt_ShowValidHoleFits + | Opt_SortValidHoleFits + | Opt_SortBySizeHoleFits + | Opt_SortBySubsumHoleFits + | Opt_AbstractRefHoleFits + | Opt_UnclutterValidHoleFits + | Opt_ShowTypeAppOfHoleFits + | Opt_ShowTypeAppVarsOfHoleFits + | Opt_ShowDocsOfHoleFits + | Opt_ShowTypeOfHoleFits + | Opt_ShowProvOfHoleFits + | Opt_ShowMatchesOfHoleFits + + | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] + + -- Suppress all coercions, them replacing with '...' + | Opt_SuppressCoercions + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressUnfoldings + -- Suppress the details of even stable unfoldings + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + | Opt_SuppressStgExts + | Opt_SuppressTicks -- Replaces Opt_PprShowTicks + | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps + + -- temporary flags + | Opt_AutoLinkPackages + | Opt_ImplicitImportQualified + + -- keeping stuff + | Opt_KeepHscppFiles + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + | Opt_KeepHiFiles + | Opt_KeepOFiles + + | Opt_BuildDynamicToo + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + | Opt_PluginTrustworthy + + | Opt_G_NoStateHack + | Opt_G_NoOptCoercion + deriving (Eq, Show, Enum) + +-- Check whether a flag should be considered an "optimisation flag" +-- for purposes of recompilation avoidance (see +-- Note [Ignoring some flag changes] in FlagChecker). Being listed here is +-- not a guarantee that the flag has no other effect. We could, and +-- perhaps should, separate out the flags that have some minor impact on +-- program semantics and/or error behavior (e.g., assertions), but +-- then we'd need to go to extra trouble (and an additional flag) +-- to allow users to ignore the optimisation level even though that +-- means ignoring some change. +optimisationFlags :: EnumSet GeneralFlag +optimisationFlags = EnumSet.fromList + [ Opt_CallArity + , Opt_Strictness + , Opt_LateDmdAnal + , Opt_KillAbsence + , Opt_KillOneShot + , Opt_FullLaziness + , Opt_FloatIn + , Opt_LateSpecialise + , Opt_Specialise + , Opt_SpecialiseAggressively + , Opt_CrossModuleSpecialise + , Opt_StaticArgumentTransformation + , Opt_CSE + , Opt_StgCSE + , Opt_StgLiftLams + , Opt_LiberateCase + , Opt_SpecConstr + , Opt_SpecConstrKeen + , Opt_DoLambdaEtaExpansion + , Opt_IgnoreAsserts + , Opt_DoEtaReduction + , Opt_CaseMerge + , Opt_CaseFolding + , Opt_UnboxStrictFields + , Opt_UnboxSmallStrictFields + , Opt_DictsCheap + , Opt_EnableRewriteRules + , Opt_RegsGraph + , Opt_RegsIterative + , Opt_PedanticBottoms + , Opt_LlvmTBAA + , Opt_LlvmFillUndefWithGarbage + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_OmitYields + , Opt_FunToThunk + , Opt_DictsStrict + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CfgBlocklayout + , Opt_WeightlessBlocklayout + , Opt_CprAnal + , Opt_WorkerWrapper + , Opt_SolveConstantDicts + , Opt_CatchBottoms + , Opt_IgnoreAsserts + ] + +-- | Used when outputting warnings: if a reason is given, it is +-- displayed. If a warning isn't controlled by a flag, this is made +-- explicit at the point of use. +data WarnReason + = NoReason + -- | Warning was enabled with the flag + | Reason !WarningFlag + -- | Warning was made an error because of -Werror or -Werror=WarningFlag + | ErrReason !(Maybe WarningFlag) + deriving Show + +-- | Used to differentiate the scope an include needs to apply to. +-- We have to split the include paths to avoid accidentally forcing recursive +-- includes since -I overrides the system search paths. See #14312. +data IncludeSpecs + = IncludeSpecs { includePathsQuote :: [String] + , includePathsGlobal :: [String] + } + deriving Show + +-- | Append to the list of includes a path that shall be included using `-I` +-- when the C compiler is called. These paths override system search paths. +addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addGlobalInclude spec paths = let f = includePathsGlobal spec + in spec { includePathsGlobal = f ++ paths } + +-- | Append to the list of includes a path that shall be included using +-- `-iquote` when the C compiler is called. These paths only apply when quoted +-- includes are used. e.g. #include "foo.h" +addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addQuoteInclude spec paths = let f = includePathsQuote spec + in spec { includePathsQuote = f ++ paths } + +-- | Concatenate and flatten the list of global and quoted includes returning +-- just a flat list of paths. +flattenIncludes :: IncludeSpecs -> [String] +flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json (Reason wf) = JSString (show wf) + json (ErrReason Nothing) = JSString "Opt_WarnIsError" + json (ErrReason (Just wf)) = JSString (show wf) + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnRedundantConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSignatures + | Opt_WarnMissingLocalSignatures + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedTopBinds + | Opt_WarnUnusedLocalBinds + | Opt_WarnUnusedPatternBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnUnusedTypePatterns + | Opt_WarnUnusedForalls + | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantRecordWildcards + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnMissingMonadFailInstances -- since 8.0 + | Opt_WarnSemigroup -- since 8.0 + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnMissedSpecs + | Opt_WarnAllMissedSpecs + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnMissedExtraSharedLib + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSignatures + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + | Opt_WarnDeferredTypeErrors + | Opt_WarnDeferredOutOfScopeVariables + | Opt_WarnNonCanonicalMonadInstances -- since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- since 8.0 + | Opt_WarnSimplifiableClassConstraints -- Since 8.2 + | Opt_WarnCPPUndef -- Since 8.2 + | Opt_WarnUnbangedStrictPatterns -- Since 8.2 + | Opt_WarnMissingHomeModules -- Since 8.2 + | Opt_WarnPartialFields -- Since 8.4 + | Opt_WarnMissingExportList + | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- Since 8.6 + | Opt_WarnStarBinder -- Since 8.6 + | Opt_WarnImplicitKindVars -- Since 8.6 + | Opt_WarnSpaceAfterBang + | Opt_WarnMissingDerivingStrategies -- Since 8.8 + | Opt_WarnPrepositiveQualifiedModule -- Since TBD + | Opt_WarnUnusedPackages -- Since 8.10 + | Opt_WarnInferredSafeImports -- Since 8.10 + | Opt_WarnMissingSafeHaskellMode -- Since 8.10 + | Opt_WarnCompatUnqualifiedImports -- Since 8.10 + | Opt_WarnDerivingDefaults + deriving (Eq, Show, Enum) + +data Language = Haskell98 | Haskell2010 + deriving (Eq, Enum, Show) + +instance Outputable Language where + ppr = text . show + +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None -- ^ inferred unsafe + | Sf_Unsafe -- ^ declared and checked + | Sf_Trustworthy -- ^ declared and checked + | Sf_Safe -- ^ declared and checked + | Sf_SafeInferred -- ^ inferred as safe + | Sf_Ignore -- ^ @-fno-safe-haskell@ state + deriving (Eq) + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_SafeInferred = "Safe-Inferred" + show Sf_Ignore = "Ignore" + +instance Outputable SafeHaskellMode where + ppr = text . show + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + hscTarget :: HscTarget, + + -- formerly Settings + ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, + fileSettings :: {-# UNPACK #-} !FileSettings, + targetPlatform :: Platform, -- Filled in by SysTools + toolSettings :: {-# UNPACK #-} !ToolSettings, + platformMisc :: {-# UNPACK #-} !PlatformMisc, + platformConstants :: PlatformConstants, + rawSettings :: [(String, String)], + + integerLibrary :: IntegerLibrary, + -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overridden + -- by GHC-API users. See Note [The integer library] in PrelNames + llvmConfig :: LlvmConfig, + -- ^ N.B. It's important that this field is lazy since we load the LLVM + -- configuration lazily. See Note [LLVM Configuration] in SysTools. + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + optLevel :: Int, -- ^ Optimisation level + debugLevel :: Int, -- ^ How much debug information to produce + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + ruleCheck :: Maybe String, + inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about + strictnessBefore :: [Int], -- ^ Additional demand analysis + + parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel + -- in --make mode, where Nothing ==> compile as + -- many in parallel as there are CPUs. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages + maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show + -- in typed hole error messages + maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole + -- fits to show in typed hole error + -- messages + refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for + -- refinement hole fits in typed hole + -- error messages + maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show + -- in non-exhaustiveness warnings + maxPmCheckModels :: Int, -- ^ Soft limit on the number of models + -- the pattern match checker checks + -- a pattern against. A safe guard + -- against exponential blow-up. + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr + specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function + specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types + -- Not optional; otherwise ForceSpecConstr can diverge. + binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above + -- this threshold will be dumped in a binary file + -- by the assembler code generator (0 to disable) + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See CoreMonad.FloatOutSwitches + + liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- recursive function. + liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- non-recursive function. + liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call + -- into an unknown call. + + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + + historySize :: Int, -- ^ Simplification history size + + importPaths :: [FilePath], + mainModIs :: Module, + mainFunIs :: Maybe String, + reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth + solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver + -- Typically only 1 is needed + + thisInstalledUnitId :: InstalledUnitId, + thisComponentId_ :: Maybe ComponentId, + thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], + + -- ways + ways :: [Way], -- ^ Way flags from the command line + buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + hieDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf :: String, + hcSuf :: String, + hiSuf :: String, + hieSuf :: String, + + canGenerateDynamicToo :: IORef Bool, + dynObjectSuf :: String, + dynHiSuf :: String, + + outputFile :: Maybe String, + dynOutputFile :: Maybe String, + outputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + -- | This is set by 'GHC.Driver.Pipeline.runPipeline' based on where + -- its output is going. + dumpPrefix :: Maybe FilePath, + + -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: IncludeSpecs, + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + rtsOptsSuggestions :: Bool, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], + frontendPluginOpts :: [String], + -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + cachedPlugins :: [LoadedPlugin], + -- ^ plugins dynamically loaded after processing arguments. What will be + -- loaded here is directed by pluginModNames. Arguments are loaded from + -- pluginModNameOpts. The purpose of this field is to cache the plugins so + -- they don't have to be loaded each time they are needed. See + -- 'GHC.Runtime.Loader.initializePlugins'. + staticPlugins :: [StaticPlugin], + -- ^ static plugins which do not need dynamic loading. These plugins are + -- intended to be added by GHC API users directly to this list. + -- + -- To add dynamically loaded plugins through the GHC API see + -- 'addPluginModuleName' instead. + + -- GHC API hooks + hooks :: Hooks, + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depIncludeCppDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + packageDBFlags :: [PackageDBFlag], + -- ^ The @-package-db@ flags given on the command line, In + -- *reverse* order that they're specified on the command line. + -- This is intended to be applied with the list of "initial" + -- package databases derived from @GHC_PACKAGE_PATH@; see + -- 'getPackageConfRefs'. + + ignorePackageFlags :: [IgnorePackageFlag], + -- ^ The @-ignore-package@ flags from the command line. + -- In *reverse* order that they're specified on the command line. + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line. + -- In *reverse* order that they're specified on the command line. + pluginPackageFlags :: [PackageFlag], + -- ^ The @-plugin-package-id@ flags from command line. + -- In *reverse* order that they're specified on the command line. + trustFlags :: [TrustFlag], + -- ^ The @-trust@ and @-distrust@ flags. + -- In *reverse* order that they're specified on the command line. + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + pkgDatabase :: Maybe [PackageDatabase], + -- ^ Stack of package databases for the target platform. + -- + -- A "package database" is a misleading name as it is really a Unit + -- database (cf Note [The identifier lexicon]). + -- + -- This field is populated by `initPackages`. + -- + -- 'Nothing' means the databases have never been read from disk. If + -- `initPackages` is called again, it doesn't reload the databases from + -- disk. + + pkgState :: PackageState, + -- ^ Consolidated unit database built by 'initPackages' from the package + -- databases in 'pkgDatabase' and flags ('-ignore-package', etc.). + -- + -- It also contains mapping from module names to actual Modules. + + -- Temporary files + -- These have to be IORefs, because the defaultCleanupHandler needs to + -- know what to clean when an exception happens + filesToClean :: IORef FilesToClean, + dirsToClean :: IORef (Map FilePath FilePath), + -- The next available suffix to uniquely name a temp file, updated atomically + nextTempSuffix :: IORef Int, + + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + + -- hsc dynamic flags + dumpFlags :: EnumSet DumpFlag, + generalFlags :: EnumSet GeneralFlag, + warningFlags :: EnumSet WarningFlag, + fatalWarningFlags :: EnumSet WarningFlag, + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + -- Here we collect the settings of the language extensions + -- from the command line, the ghci config file and + -- from interactive :set / :seti commands. + extensions :: [OnOff LangExt.Extension], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used + -- by template-haskell + extensionFlags :: EnumSet LangExt.Extension, + + -- Unfolding control + -- See Note [Discounts and thresholds] in CoreUnfold + ufCreationThreshold :: Int, + ufUseThreshold :: Int, + ufFunAppDiscount :: Int, + ufDictDiscount :: Int, + ufKeenessFactor :: Float, + ufDearOp :: Int, + ufVeryAggressive :: Bool, + + maxWorkerArgs :: Int, + + ghciHistSize :: Int, + + -- | MsgDoc output action: use "ErrUtils" instead of this if you can + log_action :: LogAction, + dump_action :: DumpAction, + trace_action :: TraceAction, + flushOut :: FlushOut, + flushErr :: FlushErr, + + ghcVersionFile :: Maybe FilePath, + haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + + useUnicode :: Bool, + useColor :: OverridingBool, + canUseColor :: Bool, + colScheme :: Col.Scheme, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + + interactivePrint :: Maybe String, + + nextWrapperNum :: IORef (ModuleEnv Int), + + -- | Machine dependent flags (-m<blah> stuff) + sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + + -- | Run-time linker information (what options we need, etc.) + rtldInfo :: IORef (Maybe LinkerInfo), + + -- | Run-time compiler information + rtccInfo :: IORef (Maybe CompilerInfo), + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int, + + -- | Reverse the order of error messages in GHC/GHCi + reverseErrors :: Bool, + + -- | Limit the maximum number of errors to show + maxErrors :: Maybe Int, + + -- | Unique supply configuration for testing build determinism + initialUnique :: Int, + uniqueIncrement :: Int, + + -- | Temporary: CFG Edge weights for fast iterations + cfgWeightInfo :: CfgWeights +} + +-- | Edge weights to use when generating a CFG from CMM +data CfgWeights + = CFGWeights + { uncondWeight :: Int + , condBranchWeight :: Int + , switchWeight :: Int + , callWeight :: Int + , likelyCondWeight :: Int + , unlikelyCondWeight :: Int + , infoTablePenalty :: Int + , backEdgeBonus :: Int + } + +defaultCfgWeights :: CfgWeights +defaultCfgWeights + = CFGWeights + { uncondWeight = 1000 + , condBranchWeight = 800 + , switchWeight = 1 + , callWeight = -10 + , likelyCondWeight = 900 + , unlikelyCondWeight = 300 + , infoTablePenalty = 300 + , backEdgeBonus = 400 + } + +parseCfgWeights :: String -> CfgWeights -> CfgWeights +parseCfgWeights s oldWeights = + foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments + where + assignments = map assignment $ settings s + update "uncondWeight" n w = + w {uncondWeight = n} + update "condBranchWeight" n w = + w {condBranchWeight = n} + update "switchWeight" n w = + w {switchWeight = n} + update "callWeight" n w = + w {callWeight = n} + update "likelyCondWeight" n w = + w {likelyCondWeight = n} + update "unlikelyCondWeight" n w = + w {unlikelyCondWeight = n} + update "infoTablePenalty" n w = + w {infoTablePenalty = n} + update "backEdgeBonus" n w = + w {backEdgeBonus = n} + update other _ _ + = panic $ other ++ + " is not a cfg weight parameter. " ++ + exampleString + settings s + | (s1,rest) <- break (== ',') s + , null rest + = [s1] + | (s1,rest) <- break (== ',') s + = s1 : settings (drop 1 rest) + + assignment as + | (name, _:val) <- break (== '=') as + = (name,read val) + | otherwise + = panic $ "Invalid cfg parameters." ++ exampleString + + exampleString = "Example parameters: uncondWeight=1000," ++ + "condBranchWeight=800,switchWeight=0,callWeight=300" ++ + ",likelyCondWeight=900,unlikelyCondWeight=300" ++ + ",infoTablePenalty=300,backEdgeBonus=400" + +backendMaintainsCfg :: DynFlags -> Bool +backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of + -- ArchX86 -- Should work but not tested so disabled currently. + ArchX86_64 -> True + _otherwise -> False + +class HasDynFlags m where + getDynFlags :: m DynFlags + +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- | See Note [LLVM Configuration] in SysTools. +data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] + , llvmPasses :: [(Int, String)] + } + +----------------------------------------------------------------------------- +-- Accessessors from 'DynFlags' + +-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the +-- vast majority of code. But GHCi questionably uses this to produce a default +-- 'DynFlags' from which to compute a flags diff for printing. +settings :: DynFlags -> Settings +settings dflags = Settings + { sGhcNameVersion = ghcNameVersion dflags + , sFileSettings = fileSettings dflags + , sTargetPlatform = targetPlatform dflags + , sToolSettings = toolSettings dflags + , sPlatformMisc = platformMisc dflags + , sPlatformConstants = platformConstants dflags + , sRawSettings = rawSettings dflags + } + +programName :: DynFlags -> String +programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags +projectVersion :: DynFlags -> String +projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = fileSettings_toolDir $ fileSettings dflags +topDir :: DynFlags -> FilePath +topDir dflags = fileSettings_topDir $ fileSettings dflags +tmpDir :: DynFlags -> String +tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags +globalPackageDatabasePath :: DynFlags -> FilePath +globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags +pgm_L :: DynFlags -> String +pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags +pgm_F :: DynFlags -> String +pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags +pgm_c :: DynFlags -> String +pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags +pgm_T :: DynFlags -> String +pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags +pgm_windres :: DynFlags -> String +pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags +pgm_lcc :: DynFlags -> (String,[Option]) +pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags +pgm_ar :: DynFlags -> String +pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags +pgm_i :: DynFlags -> String +pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags +opt_L :: DynFlags -> [String] +opt_L dflags = toolSettings_opt_L $ toolSettings dflags +opt_P :: DynFlags -> [String] +opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_P (toolSettings dflags) + +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_P_signature :: DynFlags -> ([String], Fingerprint) +opt_P_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , toolSettings_opt_P_fingerprint $ toolSettings dflags + ) + +opt_F :: DynFlags -> [String] +opt_F dflags= toolSettings_opt_F $ toolSettings dflags +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_c (toolSettings dflags) +opt_cxx :: DynFlags -> [String] +opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags +opt_a :: DynFlags -> [String] +opt_a dflags= toolSettings_opt_a $ toolSettings dflags +opt_l :: DynFlags -> [String] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_l (toolSettings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags +opt_lcc :: DynFlags -> [String] +opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags +opt_lo :: DynFlags -> [String] +opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags +opt_lc :: DynFlags -> [String] +opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags +opt_i :: DynFlags -> [String] +opt_i dflags= toolSettings_opt_i $ toolSettings dflags + +tablesNextToCode :: DynFlags -> Bool +tablesNextToCode = platformMisc_tablesNextToCode . platformMisc + +-- | The directory for this version of ghc in the user's app directory +-- (typically something like @~/.ghc/x86_64-linux-7.6.3@) +-- +versionedAppDir :: DynFlags -> MaybeT IO FilePath +versionedAppDir dflags = do + -- Make sure we handle the case the HOME isn't set (see #11678) + appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) + return $ appdir </> versionedFilePath dflags + +versionedFilePath :: DynFlags -> FilePath +versionedFilePath dflags = uniqueSubdir $ platformMini $ targetPlatform dflags + +-- | The target code type of the compilation (if any). +-- +-- Whenever you change the target, also make sure to set 'ghcLink' to +-- something sensible. +-- +-- 'HscNothing' can be used to avoid generating any output, however, note +-- that: +-- +-- * If a program uses Template Haskell the typechecker may need to run code +-- from an imported module. To facilitate this, code generation is enabled +-- for modules imported by modules that use template haskell. +-- See Note [-fno-code mode]. +-- +data HscTarget + = HscC -- ^ Generate C code. + | HscAsm -- ^ Generate assembly using the native code generator. + | HscLlvm -- ^ Generate assembly using the llvm code generator. + | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') + | HscNothing -- ^ Don't generate any code. See notes above. + deriving (Eq, Show) + +-- | Will this target result in an object file on the disk? +isObjectTarget :: HscTarget -> Bool +isObjectTarget HscC = True +isObjectTarget HscAsm = True +isObjectTarget HscLlvm = True +isObjectTarget _ = False + +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + +-- | The 'GhcMode' tells us whether we're doing multi-module +-- compilation (controlled via the "GHC" API) or one-shot +-- (single-module) compilation. This makes a difference primarily to +-- the "Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +-- | We accept flags which make packages visible, but how they select +-- the package varies; this data type reflects what selection criterion +-- is used. +data PackageArg = + PackageArg String -- ^ @-package@, by 'PackageName' + | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' + deriving (Eq, Show) +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid + +-- | Represents the renaming that may be associated with an exposed +-- package, e.g. the @rns@ part of @-package "foo (rns)"@. +-- +-- Here are some example parsings of the package flags (where +-- a string literal is punned to be a 'ModuleName': +-- +-- * @-package foo@ is @ModRenaming True []@ +-- * @-package foo ()@ is @ModRenaming False []@ +-- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ +-- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ +-- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ +data ModRenaming = ModRenaming { + modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? + modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope + -- under name @n@. + } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) + +-- | Flags for manipulating the set of non-broken packages. +newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ + deriving (Eq) + +-- | Flags for manipulating package trust. +data TrustFlag + = TrustPackage String -- ^ @-trust@ + | DistrustPackage String -- ^ @-distrust@ + deriving (Eq) + +-- | Flags for manipulating packages visibility. +data PackageFlag + = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ + | HidePackage String -- ^ @-hide-package@ + deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + +data PackageDBFlag + = PackageDB PkgDbRef + | NoUserPackageDB + | NoGlobalPackageDB + | ClearPackageDBs + deriving (Eq) + +packageFlagsChanged :: DynFlags -> DynFlags -> Bool +packageFlagsChanged idflags1 idflags0 = + packageFlags idflags1 /= packageFlags idflags0 || + ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || + pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || + trustFlags idflags1 /= trustFlags idflags0 || + packageDBFlags idflags1 /= packageDBFlags idflags0 || + packageGFlags idflags1 /= packageGFlags idflags0 + where + packageGFlags dflags = map (`gopt` dflags) + [ Opt_HideAllPackages + , Opt_HideAllPluginPackages + , Opt_AutoLinkPackages ] + +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + +-- | The 'HscTarget' value corresponding to the default way to create +-- object files on the current platform. + +defaultHscTarget :: Platform -> PlatformMisc -> HscTarget +defaultHscTarget platform pMisc + | platformUnregisterised platform = HscC + | platformMisc_ghcWithNativeCodeGen pMisc = HscAsm + | otherwise = HscLlvm + +defaultObjectTarget :: DynFlags -> HscTarget +defaultObjectTarget dflags = defaultHscTarget + (targetPlatform dflags) + (platformMisc dflags) + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll + deriving (Show) + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +data Way + = WayCustom String -- for GHC API clients building custom variants + | WayThreaded + | WayDebug + | WayProf + | WayEventLog + | WayDyn + deriving (Eq, Ord, Show) + +allowed_combination :: [Way] -> Bool +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + (WayCustom {}) `allowedWith` _ = True + WayThreaded `allowedWith` WayProf = True + WayThreaded `allowedWith` WayEventLog = True + WayProf `allowedWith` WayEventLog = True + _ `allowedWith` _ = False + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" + +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayEventLog = True + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" + +-- Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] + -- We could get away without adding -fPIC when compiling the + -- modules of a program that is to be linked with -dynamic; the + -- program itself does not need to be position-independent, only + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] +wayGeneralFlags _ WayEventLog = [] + +-- Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting + -- when we're going to be dynamically + -- linking. Plus it breaks compilation + -- on OSX x86. + Opt_SplitSections] +wayUnsetGeneralFlags _ WayProf = [] +wayUnsetGeneralFlags _ WayEventLog = [] + +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] +wayOptc _ WayEventLog = ["-DTRACING"] + +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + -- N.B. FreeBSD cc throws a warning if we pass -pthread without + -- actually using any pthread symbols. + OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] +wayOptl _ WayEventLog = [] + +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] +wayOptP _ WayEventLog = ["-DTRACING"] + +whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) + +ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g + +whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenCannotGenerateDynamicToo dflags f + = ifCannotGenerateDynamicToo dflags f (return ()) + +ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifCannotGenerateDynamicToo dflags f g + = generateDynamicTooConditional dflags g f g + +generateDynamicTooConditional :: MonadIO m + => DynFlags -> m a -> m a -> m a -> m a +generateDynamicTooConditional dflags canGen cannotGen notTryingToGen + = if gopt Opt_BuildDynamicToo dflags + then do let ref = canGenerateDynamicToo dflags + b <- liftIO $ readIORef ref + if b then canGen else cannotGen + else notTryingToGen + +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = updateWays dflags2 + dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo + in dflags4 + +-- | Compute the path of the dynamic object corresponding to an object file. +dynamicOutputFile :: DynFlags -> FilePath -> FilePath +dynamicOutputFile dflags outputFile = dynOut outputFile + where + dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo + refNextTempSuffix <- newIORef 0 + refFilesToClean <- newIORef emptyFilesToClean + refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty + refRtldInfo <- newIORef Nothing + refRtccInfo <- newIORef Nothing + wrapperNum <- newIORef emptyModuleEnv + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" + let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode + canUseColor <- stderrSupportsAnsiColors + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) + return dflags{ + canGenerateDynamicToo = refCanGenerateDynamicToo, + nextTempSuffix = refNextTempSuffix, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps, + nextWrapperNum = wrapperNum, + useUnicode = useUnicode', + useColor = useColor', + canUseColor = canUseColor, + colScheme = colScheme', + rtldInfo = refRtldInfo, + rtccInfo = refRtccInfo + } + +-- | The normal 'DynFlags'. Note that they are not suitable for use in this form +-- and must be fully initialized by 'GHC.runGhc' first. +defaultDynFlags :: Settings -> LlvmConfig -> DynFlags +defaultDynFlags mySettings llvmConfig = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + hscTarget = defaultHscTarget (sTargetPlatform mySettings) (sPlatformMisc mySettings), + integerLibrary = sIntegerLibraryType mySettings, + verbosity = 0, + optLevel = 0, + debugLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + ruleCheck = Nothing, + inlineCheck = Nothing, + binBlobThreshold = 500000, -- 500K is a good default (see #16190) + maxRelevantBinds = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, + maxUncoveredPatterns = 4, + maxPmCheckModels = 30, + simplTickFactor = 100, + specConstrThreshold = Just 2000, + specConstrCount = Just 3, + specConstrRecursive = 3, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsKnown = False, -- Default: don't turn known calls into unknown ones + cmmProcAlignment = Nothing, + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Just 1, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + importPaths = ["."], + mainModIs = mAIN, + mainFunIs = Nothing, + reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, + solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, + + thisInstalledUnitId = toInstalledUnitId mainUnitId, + thisUnitIdInsts_ = Nothing, + thisComponentId_ = Nothing, + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + hieDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf = "hi", + hieSuf = "hie", + + canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", + dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf = "dyn_hi", + + pluginModNames = [], + pluginModNameOpts = [], + frontendPluginOpts = [], + cachedPlugins = [], + staticPlugins = [], + hooks = emptyHooks, + + outputFile = Nothing, + dynOutputFile = Nothing, + outputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = Nothing, + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = IncludeSpecs [] [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + rtsOptsSuggestions = True, + + hpcDir = ".hpc", + + packageDBFlags = [], + packageFlags = [], + pluginPackageFlags = [], + ignorePackageFlags = [], + trustFlags = [], + packageEnv = Nothing, + pkgDatabase = Nothing, + pkgState = emptyPackageState, + ways = defaultWays mySettings, + buildTag = mkBuildTag (defaultWays mySettings), + splitInfo = Nothing, + + ghcNameVersion = sGhcNameVersion mySettings, + fileSettings = sFileSettings mySettings, + toolSettings = sToolSettings mySettings, + targetPlatform = sTargetPlatform mySettings, + platformMisc = sPlatformMisc mySettings, + platformConstants = sPlatformConstants mySettings, + rawSettings = sRawSettings mySettings, + + -- See Note [LLVM configuration]. + llvmConfig = llvmConfig, + + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depIncludeCppDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", + filesToClean = panic "defaultDynFlags: No filesToClean", + dirsToClean = panic "defaultDynFlags: No dirsToClean", + generatedDumps = panic "defaultDynFlags: No generatedDumps", + ghcVersionFile = Nothing, + haddockOptions = Nothing, + dumpFlags = EnumSet.empty, + generalFlags = EnumSet.fromList (defaultFlags mySettings), + warningFlags = EnumSet.fromList standardWarnings, + fatalWarningFlags = EnumSet.empty, + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + -- The ufCreationThreshold threshold must be reasonably high to + -- take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline + -- into Csg.calc (The unfolding for sqr never makes it into the + -- interface file.) + ufCreationThreshold = 750, + ufUseThreshold = 60, + ufFunAppDiscount = 60, + -- Be fairly keen to inline a function if that means + -- we'll be able to pick the right method from a dictionary + ufDictDiscount = 30, + ufKeenessFactor = 1.5, + ufDearOp = 40, + ufVeryAggressive = False, + + maxWorkerArgs = 10, + + ghciHistSize = 50, -- keep a log of length 50 by default + + -- Logging + + log_action = defaultLogAction, + dump_action = defaultDumpAction, + trace_action = defaultTraceAction, + + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + useUnicode = False, + useColor = Auto, + canUseColor = False, + colScheme = Col.defaultScheme, + profAuto = NoProfAuto, + interactivePrint = Nothing, + nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", + sseVersion = Nothing, + bmiVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + rtldInfo = panic "defaultDynFlags: no rtldInfo", + rtccInfo = panic "defaultDynFlags: no rtccInfo", + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32, + + initialUnique = 0, + uniqueIncrement = 1, + + reverseErrors = False, + maxErrors = Nothing, + cfgWeightInfo = defaultCfgWeights + } + +defaultWays :: Settings -> [Way] +defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) + then [WayDyn] + else [] + +interpWays :: [Way] +interpWays + | dynamicGhc = [WayDyn] + | rtsIsProfiled = [WayProf] + | otherwise = [] + +interpreterProfiled :: DynFlags -> Bool +interpreterProfiled dflags + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + +interpreterDynamic :: DynFlags -> Bool +interpreterDynamic dflags + | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags + | otherwise = dynamicGhc + +-------------------------------------------------------------------------- +-- +-- Note [JSON Error Messages] +-- +-- When the user requests the compiler output to be dumped as json +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. +-- +-- Before the compiler calls log_action, it has already turned the `ErrMsg` +-- into a formatted message. This means that we lose some possible +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. + +type FatalMessager = String -> IO () + +type LogAction = DynFlags + -> WarnReason + -> Severity + -> SrcSpan + -> PprStyle + -> MsgDoc + -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + + +-- See Note [JSON Error Messages] +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan _style msg + = do + defaultLogActionHPutStrDoc dflags stdout (doc $$ text "") + (mkCodeStyle CStyle) + where + doc = renderJSON $ + JSObject [ ( "span", json srcSpan ) + , ( "doc" , JSString (showSDoc dflags msg) ) + , ( "severity", json severity ) + , ( "reason" , json reason ) + ] + + +defaultLogAction :: LogAction +defaultLogAction dflags reason severity srcSpan style msg + = case severity of + SevOutput -> printOut msg style + SevDump -> printOut (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageAnn flagMsg severity srcSpan msg + + printWarns = do + hPutChar stderr '\n' + caretDiagnostic <- + if gopt Opt_DiagnosticsShowCaret dflags + then getCaretDiagnostic severity srcSpan + else pure empty + printErrs (message $+$ caretDiagnostic) + (setStyleColoured True style) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + + flagMsg = + case reason of + NoReason -> Nothing + Reason wflag -> do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + ErrReason Nothing -> + return "-Werror" + ErrReason (Just wflag) -> do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + + warnFlagGrp flag + | gopt Opt_ShowWarnGroups dflags = + case smallestGroups flag of + [] -> "" + groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = "" + +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPrintDoc dflags h d sty + = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty + +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPutStrDoc dflags h d sty + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc Pretty.PageMode dflags h sty d + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +data OnOff a = On a + | Off a + deriving (Eq, Show) + +instance Outputable a => Outputable (OnOff a) where + ppr (On x) = text "On" <+> ppr x + ppr (Off x) = text "Off" <+> ppr x + +-- OnOffs accumulate in reverse order, so we use foldr in order to +-- process them in the right order +flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension +flattenExtensionFlags ml = foldr f defaultExtensionFlags + where f (On f) flags = EnumSet.insert f flags + f (Off f) flags = EnumSet.delete f flags + defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) + +-- | The language extensions implied by the various language variants. +-- When updating this be sure to update the flag documentation in +-- @docs/users-guide/glasgow_exts.rst@. +languageExtensions :: Maybe Language -> [LangExt.Extension] + +languageExtensions Nothing + -- Nothing => the default case + = LangExt.NondecreasingIndentation -- This has been on by default for some time + : delete LangExt.DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) + + -- NB: MonoPatBinds is no longer the default + +languageExtensions (Just Haskell98) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.NPlusKPatterns, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + +languageExtensions (Just Haskell2010) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.RelaxedPolyRec] + +hasPprDebug :: DynFlags -> Bool +hasPprDebug = dopt Opt_D_ppr_debug + +hasNoDebugOutput :: DynFlags -> Bool +hasNoDebugOutput = dopt Opt_D_no_debug_output + +hasNoStateHack :: DynFlags -> Bool +hasNoStateHack = gopt Opt_G_NoStateHack + +hasNoOptCoercion :: DynFlags -> Bool +hasNoOptCoercion = gopt Opt_G_NoOptCoercion + + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt f dflags = (f `EnumSet.member` dumpFlags dflags) + || (verbosity dflags >= 4 && enableIfVerbose f) + where enableIfVerbose Opt_D_dump_tc_trace = False + enableIfVerbose Opt_D_dump_rn_trace = False + enableIfVerbose Opt_D_dump_cs_trace = False + enableIfVerbose Opt_D_dump_if_trace = False + enableIfVerbose Opt_D_dump_vt_trace = False + enableIfVerbose Opt_D_dump_tc = False + enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_rn_stats = False + enableIfVerbose Opt_D_dump_hi_diffs = False + enableIfVerbose Opt_D_verbose_core2core = False + enableIfVerbose Opt_D_verbose_stg2stg = False + enableIfVerbose Opt_D_dump_splices = False + enableIfVerbose Opt_D_th_dec_file = False + enableIfVerbose Opt_D_dump_rule_firings = False + enableIfVerbose Opt_D_dump_rule_rewrites = False + enableIfVerbose Opt_D_dump_simpl_trace = False + enableIfVerbose Opt_D_dump_rtti = False + enableIfVerbose Opt_D_dump_inlinings = False + enableIfVerbose Opt_D_dump_core_stats = False + enableIfVerbose Opt_D_dump_asm_stats = False + enableIfVerbose Opt_D_dump_types = False + enableIfVerbose Opt_D_dump_simpl_iterations = False + enableIfVerbose Opt_D_dump_ticked = False + enableIfVerbose Opt_D_dump_view_pattern_commoning = False + enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False + enableIfVerbose Opt_D_dump_ec_trace = False + enableIfVerbose _ = True + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +gopt :: GeneralFlag -> DynFlags -> Bool +gopt f dflags = f `EnumSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `EnumSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } + +-- | Test whether a 'WarningFlag' is set as fatal +wopt_fatal :: WarningFlag -> DynFlags -> Bool +wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags + +-- | Mark a 'WarningFlag' as fatal (do not set the flag) +wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_set_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } + +-- | Mark a 'WarningFlag' as not fatal +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + +-- | Test whether a 'LangExt.Extension' is set +xopt :: LangExt.Extension -> DynFlags -> Bool +xopt f dflags = f `EnumSet.member` extensionFlags dflags + +-- | Set a 'LangExt.Extension' +xopt_set :: DynFlags -> LangExt.Extension -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'LangExt.Extension' +xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Set or unset a 'LangExt.Extension', unless it has been explicitly +-- set or unset before. +xopt_set_unlessExplSpec + :: LangExt.Extension + -> (DynFlags -> LangExt.Extension -> DynFlags) + -> DynFlags -> DynFlags +xopt_set_unlessExplSpec ext setUnset dflags = + let referedExts = stripOnOff <$> extensions dflags + stripOnOff (On x) = x + stripOnOff (Off x) = x + in + if ext `elem` referedExts then dflags else setUnset dflags ext + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags + +safeHaskellModeEnabled :: DynFlags -> Bool +safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy + , Sf_Safe ] + + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell 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 -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore + | a == b = return a + | otherwise = addErr errm >> pure a + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt LangExt.GeneralizedNewtypeDeriving, + flip xopt_unset LangExt.GeneralizedNewtypeDeriving) + , ("-XTemplateHaskell", thOnLoc, + xopt LangExt.TemplateHaskell, + flip xopt_unset LangExt.TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags + + +-- | 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 + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, addOptl, addOptc, addOptcxx, addOptP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d { objectDir = Just f} +setHiDir f d = d { hiDir = Just f} +setHieDir f d = d { hieDir = Just f} +setStubDir f d = d { stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). +setDumpDir f d = d { dumpDir = Just f} +setOutputDir f = setObjectDir f + . setHieDir f + . setHiDir f + . setStubDir f + . setDumpDir f +setDylibInstallName f d = d { dylibInstallName = Just f} + +setObjectSuf f d = d { objectSuf = f} +setDynObjectSuf f d = d { dynObjectSuf = f} +setHiSuf f d = d { hiSuf = f} +setHieSuf f d = d { hieSuf = f} +setDynHiSuf f d = d { dynHiSuf = f} +setHcSuf f d = d { hcSuf = f} + +setOutputFile f d = d { outputFile = f} +setDynOutputFile f d = d { dynOutputFile = f} +setOutputHi f d = d { outputHi = f} + +setJsonLogAction :: DynFlags -> DynFlags +setJsonLogAction d = d { log_action = jsonLogAction } + +thisComponentId :: DynFlags -> ComponentId +thisComponentId dflags = + case thisComponentId_ dflags of + Just cid -> cid + Nothing -> + case thisUnitIdInsts_ dflags of + Just _ -> + throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + Nothing -> ComponentId (unitIdFS (thisPackage dflags)) + +thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] +thisUnitIdInsts dflags = + case thisUnitIdInsts_ dflags of + Just insts -> insts + Nothing -> [] + +thisPackage :: DynFlags -> UnitId +thisPackage dflags = + case thisUnitIdInsts_ dflags of + Nothing -> default_uid + Just insts + | all (\(x,y) -> mkHoleModule x == y) insts + -> newUnitId (thisComponentId dflags) insts + | otherwise + -> default_uid + where + default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) + +parseUnitIdInsts :: String -> [(ModuleName, Module)] +parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') + parseEntry = do + n <- parseModuleName + _ <- R.char '=' + m <- parseModuleId + return (n, m) + +setUnitIdInsts :: String -> DynFlags -> DynFlags +setUnitIdInsts s d = + d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } + +setComponentId :: String -> DynFlags -> DynFlags +setComponentId s d = + d { thisComponentId_ = Just (ComponentId (fsLit s)) } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +clearPluginModuleNames :: DynFlags -> DynFlags +clearPluginModuleNames d = + d { pluginModNames = [] + , pluginModNameOpts = [] + , cachedPlugins = [] } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +addFrontendPluginOption :: String -> DynFlags -> DynFlags +addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d { dynLibLoader = Deployable } + ("sysdep", "") -> d { dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) + where (pgm:args) = words f +addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) +addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) +addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + -- See Note [Repeated -optP hashing] + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + + +setDepMakefile :: FilePath -> DynFlags -> DynFlags +setDepMakefile f d = d { depMakefile = f } + +setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags +setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +addDepSuffix s d = d { depSuffixes = s : depSuffixes d } + +addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} + +addGhcVersionFile :: FilePath -> DynFlags -> DynFlags +addGhcVersionFile f d = d { ghcVersionFile = Just f } + +addHaddockOpts f d = d { haddockOptions = Just f} + +addGhciScript f d = d { ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d { interactivePrint = Just f} + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n dfs + = dfs2{ optLevel = final_n } + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + dfs1 = foldr (flip gopt_unset) dfs remove_gopts + dfs2 = foldr (flip gopt_set) dfs1 extra_gopts + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: MonadIO m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do + let ((leftover, errs, warns), dflags1) + = runCmdLine (processArgs activeFlags args) dflags0 + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ + map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + dflags3 = updateWays dflags2 + theWays = ways dflags3 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc theWays))) + + let chooseOutput + | isJust (outputFile dflags3) -- Only iff user specified -o ... + , not (isJust (dynOutputFile dflags3)) -- but not -dyno + = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile } + | otherwise + = return dflags3 + where + outFile = fromJust $ outputFile dflags3 + dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) + + let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 + + -- Set timer stats & heap size + when (enableTimeStats dflags5) $ liftIO enableTimingStats + case (ghcHeapSize dflags5) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags5 + + let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) + + return (dflags5, leftover, warns' ++ warns) + +-- | Write an error or warning to the 'LogOutput'. +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle + -> MsgDoc -> IO () +putLogMsg dflags = log_action dflags dflags + +updateWays :: DynFlags -> DynFlags +updateWays dflags + = let theWays = sort $ nub $ ways dflags + in dflags { + ways = theWays, + buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) + } + +-- | Check (and potentially disable) any extensions that aren't allowed +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags + + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) + + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] + +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) + + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + + -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference] + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings without the deprecated ones. +-- These are the user facing strings for enabling and disabling options. +allNonDeprecatedFlags :: [String] +allNonDeprecatedFlags = allFlagsDeps False + +-- | All flags with possibility to filter deprecated ones +allFlagsDeps :: Bool -> [String] +allFlagsDeps keepDeprecated = [ '-':flagName flag + | (deprecated, flag) <- flagsAllDeps + , keepDeprecated || not (isDeprecated deprecated)] + where isDeprecated Deprecated = True + isDeprecated _ = False + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = map snd flagsAllDeps + +-- All dynamic flags present in GHC with deprecation information. +flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] +flagsAllDeps = package_flags_deps ++ dynamic_flags_deps + + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = map snd dynamic_flags_deps + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = map snd package_flags_deps + +----------------Helpers to make flags and keep deprecation information---------- + +type FlagMaker m = String -> OptKind m -> Flag m +type DynFlagMaker = FlagMaker (CmdLineP DynFlags) +data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) + +-- Make a non-deprecated flag +make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_ord_flag fm name kind = (NotDeprecated, fm name kind) + +-- Make a deprecated flag +make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_dep_flag fm name kind message = (Deprecated, + fm name $ add_dep_message kind message) + +add_dep_message :: OptKind (CmdLineP DynFlags) -> String + -> OptKind (CmdLineP DynFlags) +add_dep_message (NoArg f) message = NoArg $ f >> deprecate message +add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message +add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message +add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message +add_dep_message (OptPrefix f) message = + OptPrefix $ \s -> f s >> deprecate message +add_dep_message (OptIntSuffix f) message = + OptIntSuffix $ \oi -> f oi >> deprecate message +add_dep_message (IntSuffix f) message = + IntSuffix $ \i -> f i >> deprecate message +add_dep_message (FloatSuffix f) message = + FloatSuffix $ \fl -> f fl >> deprecate message +add_dep_message (PassFlag f) message = + PassFlag $ \s -> f s >> deprecate message +add_dep_message (AnySuffix f) message = + AnySuffix $ \s -> f s >> deprecate message + +----------------------- The main flags themselves ------------------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +dynamic_flags_deps = [ + make_dep_flag defFlag "n" (NoArg $ return ()) + "The -n flag is deprecated and no longer has any effect" + , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) + , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , (Deprecated, defFlag "#include" + (HasArg (\_s -> + deprecate ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect")))) + , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) + + , make_ord_flag defGhcFlag "j" (OptIntSuffix + (\n -> case n of + Just n + | n > 0 -> upd (\d -> d { parMakeCount = Just n }) + | otherwise -> addErr "Syntax: -j[n] where n > 0" + Nothing -> upd (\d -> d { parMakeCount = Nothing }))) + -- When the number of parallel builds + -- is omitted, it is the same + -- as specifying that the number of + -- parallel builds is equal to the + -- result of getNumProcessors + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) + , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) + + -- RTS options ------------------------------------------------------------- + , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> + d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) + , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) + , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) + , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) + + , make_ord_flag defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) + , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) + , make_ord_flag defGhcFlag "rdynamic" $ noArg $ +#if defined(linux_HOST_OS) + addOptl "-rdynamic" +#elif defined(mingw32_HOST_OS) + addOptl "-Wl,--export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#endif + , make_ord_flag defGhcFlag "relative-dynlib-paths" + (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + , make_ord_flag defGhcFlag "copy-libs-when-linking" + (NoArg (setGeneralFlag Opt_SingleLibFolder)) + , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) + + ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , make_ord_flag defFlag "pgmlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } + , make_ord_flag defFlag "pgmlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } + , make_ord_flag defFlag "pgmi" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } + , make_ord_flag defFlag "pgmL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } + , make_ord_flag defFlag "pgmP" + (hasArg setPgmP) + , make_ord_flag defFlag "pgmF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } + , make_ord_flag defFlag "pgmc" + $ hasArg $ \f -> alterToolSettings $ \s -> s + { toolSettings_pgm_c = f + , -- Don't pass -no-pie with -pgmc + -- (see #15319) + toolSettings_ccSupportsNoPie = False + } + , make_ord_flag defFlag "pgms" + (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) + , make_ord_flag defFlag "pgma" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } + , make_ord_flag defFlag "pgml" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l = (f,[]) } + , make_ord_flag defFlag "pgmdll" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } + , make_ord_flag defFlag "pgmwindres" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } + , make_ord_flag defFlag "pgmlibtool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } + , make_ord_flag defFlag "pgmar" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } + , make_ord_flag defFlag "pgmranlib" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } + + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , make_ord_flag defFlag "optlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } + , make_ord_flag defFlag "optlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } + , make_ord_flag defFlag "opti" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } + , make_ord_flag defFlag "optL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } + , make_ord_flag defFlag "optP" + (hasArg addOptP) + , make_ord_flag defFlag "optF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } + , make_ord_flag defFlag "optc" + (hasArg addOptc) + , make_ord_flag defFlag "optcxx" + (hasArg addOptcxx) + , make_ord_flag defFlag "opta" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } + , make_ord_flag defFlag "optl" + (hasArg addOptl) + , make_ord_flag defFlag "optwindres" + $ hasArg $ \f -> + alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } + + , make_ord_flag defGhcFlag "split-objs" + (NoArg $ addWarn "ignoring -split-objs") + + , make_ord_flag defGhcFlag "split-sections" + (noArgM (\dflags -> do + if platformHasSubsectionsViaSymbols (targetPlatform dflags) + then do addWarn $ + "-split-sections is not useful on this platform " ++ + "since it always uses subsections via symbols. Ignoring." + return dflags + else return (gopt_set dflags Opt_SplitSections))) + + -------- ghc -M ----------------------------------------------------- + , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-cpp-deps" + (noArg (setDepIncludeCppDeps True)) + , make_ord_flag defGhcFlag "include-pkg-deps" + (noArg (setDepIncludePkgDeps True)) + , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , make_ord_flag defGhcFlag "no-link" + (noArg (\d -> d { ghcLink=NoLink })) + , make_ord_flag defGhcFlag "shared" + (noArg (\d -> d { ghcLink=LinkDynLib })) + , make_ord_flag defGhcFlag "staticlib" + (noArg (\d -> d { ghcLink=LinkStaticLib })) + , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + + ------- Libraries --------------------------------------------------- + , make_ord_flag defFlag "L" (Prefix addLibraryPath) + , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) + , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) + , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) + , make_ord_flag defGhcFlag "dyno" + (sepArg (setDynOutputFile . Just)) + , make_ord_flag defGhcFlag "ohi" + (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) + , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) + , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) + , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) + , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) + , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) + , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) + , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) + , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) + , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) + , make_ord_flag defGhcFlag "ddump-file-prefix" + (hasArg (setDumpPrefixForce . Just)) + + , make_ord_flag defGhcFlag "dynamic-too" + (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , make_ord_flag defGhcFlag "keep-hc-file" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hc-files" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-file" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-files" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-s-file" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-s-files" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-llvm-file" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + , make_ord_flag defGhcFlag "keep-llvm-files" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + -- This only makes sense as plural + , make_ord_flag defGhcFlag "keep-tmp-files" + (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + , make_ord_flag defGhcFlag "keep-hi-file" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-file" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-hi-files" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-files" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-o-file" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-file" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "keep-o-files" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-files" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + + ------- Miscellaneous ---------------------------------------------- + , make_ord_flag defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , make_ord_flag defGhcFlag "no-hs-main" + (NoArg (setGeneralFlag Opt_NoHsMain)) + , make_ord_flag defGhcFlag "fno-state-hack" + (NoArg (setGeneralFlag Opt_G_NoStateHack)) + , make_ord_flag defGhcFlag "fno-opt-coercion" + (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "with-rtsopts" + (HasArg setRtsOpts) + , make_ord_flag defGhcFlag "rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=all" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=some" + (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , make_ord_flag defGhcFlag "rtsopts=none" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "rtsopts=ignore" + (NoArg (setRtsOptsEnabled RtsOptsIgnore)) + , make_ord_flag defGhcFlag "rtsopts=ignoreAll" + (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) + , make_ord_flag defGhcFlag "no-rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "no-rtsopts-suggestions" + (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) + + , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) + , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) + , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) + , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , make_ord_flag defGhcFlag "ticky-allocd" + (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , make_ord_flag defGhcFlag "ticky-LNE" + (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-dyn-thunk" + (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + ------- recompilation checker -------------------------------------- + , make_dep_flag defGhcFlag "recomp" + (NoArg $ unSetGeneralFlag Opt_ForceRecomp) + "Use -fno-force-recomp instead" + , make_dep_flag defGhcFlag "no-recomp" + (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" + , make_ord_flag defFlag "fmax-errors" + (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) + , make_ord_flag defFlag "fno-max-errors" + (noArg (\d -> d { maxErrors = Nothing })) + , make_ord_flag defFlag "freverse-errors" + (noArg (\d -> d {reverseErrors = True} )) + , make_ord_flag defFlag "fno-reverse-errors" + (noArg (\d -> d {reverseErrors = False} )) + + ------ HsCpp opts --------------------------------------------------- + , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) + , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , make_ord_flag defFlag "I" (Prefix addIncludePath) + , make_ord_flag defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> + d { pprUserLength = n })) + , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> + d { pprCols = n })) + , make_ord_flag defFlag "fdiagnostics-color=auto" + (NoArg (upd (\d -> d { useColor = Auto }))) + , make_ord_flag defFlag "fdiagnostics-color=always" + (NoArg (upd (\d -> d { useColor = Always }))) + , make_ord_flag defFlag "fdiagnostics-color=never" + (NoArg (upd (\d -> d { useColor = Never }))) + + -- Suppress all that is suppressable in core dumps. + -- Except for uniques, as some simplifier phases introduce new variables that + -- have otherwise identical names. + , make_ord_flag defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTicks + setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressTimestamps) + + ------ Debugging ---------------------------------------------------- + , make_ord_flag defGhcFlag "dstg-stats" + (NoArg (setGeneralFlag Opt_StgStats)) + + , make_ord_flag defGhcFlag "ddump-cmm" + (setDumpFlag Opt_D_dump_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-from-stg" + (setDumpFlag Opt_D_dump_cmm_from_stg) + , make_ord_flag defGhcFlag "ddump-cmm-raw" + (setDumpFlag Opt_D_dump_cmm_raw) + , make_ord_flag defGhcFlag "ddump-cmm-verbose" + (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" + (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) + , make_ord_flag defGhcFlag "ddump-cmm-cfg" + (setDumpFlag Opt_D_dump_cmm_cfg) + , make_ord_flag defGhcFlag "ddump-cmm-cbe" + (setDumpFlag Opt_D_dump_cmm_cbe) + , make_ord_flag defGhcFlag "ddump-cmm-switch" + (setDumpFlag Opt_D_dump_cmm_switch) + , make_ord_flag defGhcFlag "ddump-cmm-proc" + (setDumpFlag Opt_D_dump_cmm_proc) + , make_ord_flag defGhcFlag "ddump-cmm-sp" + (setDumpFlag Opt_D_dump_cmm_sp) + , make_ord_flag defGhcFlag "ddump-cmm-sink" + (setDumpFlag Opt_D_dump_cmm_sink) + , make_ord_flag defGhcFlag "ddump-cmm-caf" + (setDumpFlag Opt_D_dump_cmm_caf) + , make_ord_flag defGhcFlag "ddump-cmm-procmap" + (setDumpFlag Opt_D_dump_cmm_procmap) + , make_ord_flag defGhcFlag "ddump-cmm-split" + (setDumpFlag Opt_D_dump_cmm_split) + , make_ord_flag defGhcFlag "ddump-cmm-info" + (setDumpFlag Opt_D_dump_cmm_info) + , make_ord_flag defGhcFlag "ddump-cmm-cps" + (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-cfg-weights" + (setDumpFlag Opt_D_dump_cfg_weights) + , make_ord_flag defGhcFlag "ddump-core-stats" + (setDumpFlag Opt_D_dump_core_stats) + , make_ord_flag defGhcFlag "ddump-asm" + (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-asm-native" + (setDumpFlag Opt_D_dump_asm_native) + , make_ord_flag defGhcFlag "ddump-asm-liveness" + (setDumpFlag Opt_D_dump_asm_liveness) + , make_ord_flag defGhcFlag "ddump-asm-regalloc" + (setDumpFlag Opt_D_dump_asm_regalloc) + , make_ord_flag defGhcFlag "ddump-asm-conflicts" + (setDumpFlag Opt_D_dump_asm_conflicts) + , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , make_ord_flag defGhcFlag "ddump-asm-stats" + (setDumpFlag Opt_D_dump_asm_stats) + , make_ord_flag defGhcFlag "ddump-asm-expanded" + (setDumpFlag Opt_D_dump_asm_expanded) + , make_ord_flag defGhcFlag "ddump-llvm" + (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) + , make_ord_flag defGhcFlag "ddump-deriv" + (setDumpFlag Opt_D_dump_deriv) + , make_ord_flag defGhcFlag "ddump-ds" + (setDumpFlag Opt_D_dump_ds) + , make_ord_flag defGhcFlag "ddump-ds-preopt" + (setDumpFlag Opt_D_dump_ds_preopt) + , make_ord_flag defGhcFlag "ddump-foreign" + (setDumpFlag Opt_D_dump_foreign) + , make_ord_flag defGhcFlag "ddump-inlinings" + (setDumpFlag Opt_D_dump_inlinings) + , make_ord_flag defGhcFlag "ddump-rule-firings" + (setDumpFlag Opt_D_dump_rule_firings) + , make_ord_flag defGhcFlag "ddump-rule-rewrites" + (setDumpFlag Opt_D_dump_rule_rewrites) + , make_ord_flag defGhcFlag "ddump-simpl-trace" + (setDumpFlag Opt_D_dump_simpl_trace) + , make_ord_flag defGhcFlag "ddump-occur-anal" + (setDumpFlag Opt_D_dump_occur_anal) + , make_ord_flag defGhcFlag "ddump-parsed" + (setDumpFlag Opt_D_dump_parsed) + , make_ord_flag defGhcFlag "ddump-parsed-ast" + (setDumpFlag Opt_D_dump_parsed_ast) + , make_ord_flag defGhcFlag "ddump-rn" + (setDumpFlag Opt_D_dump_rn) + , make_ord_flag defGhcFlag "ddump-rn-ast" + (setDumpFlag Opt_D_dump_rn_ast) + , make_ord_flag defGhcFlag "ddump-simpl" + (setDumpFlag Opt_D_dump_simpl) + , make_ord_flag defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , make_ord_flag defGhcFlag "ddump-spec" + (setDumpFlag Opt_D_dump_spec) + , make_ord_flag defGhcFlag "ddump-prep" + (setDumpFlag Opt_D_dump_prep) + , make_ord_flag defGhcFlag "ddump-stg" + (setDumpFlag Opt_D_dump_stg) + , make_ord_flag defGhcFlag "ddump-stg-unarised" + (setDumpFlag Opt_D_dump_stg_unarised) + , make_ord_flag defGhcFlag "ddump-stg-final" + (setDumpFlag Opt_D_dump_stg_final) + , make_ord_flag defGhcFlag "ddump-call-arity" + (setDumpFlag Opt_D_dump_call_arity) + , make_ord_flag defGhcFlag "ddump-exitify" + (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-stranal" + (setDumpFlag Opt_D_dump_stranal) + , make_ord_flag defGhcFlag "ddump-str-signatures" + (setDumpFlag Opt_D_dump_str_signatures) + , make_ord_flag defGhcFlag "ddump-cpranal" + (setDumpFlag Opt_D_dump_cpranal) + , make_ord_flag defGhcFlag "ddump-cpr-signatures" + (setDumpFlag Opt_D_dump_cpr_signatures) + , make_ord_flag defGhcFlag "ddump-tc" + (setDumpFlag Opt_D_dump_tc) + , make_ord_flag defGhcFlag "ddump-tc-ast" + (setDumpFlag Opt_D_dump_tc_ast) + , make_ord_flag defGhcFlag "ddump-types" + (setDumpFlag Opt_D_dump_types) + , make_ord_flag defGhcFlag "ddump-rules" + (setDumpFlag Opt_D_dump_rules) + , make_ord_flag defGhcFlag "ddump-cse" + (setDumpFlag Opt_D_dump_cse) + , make_ord_flag defGhcFlag "ddump-worker-wrapper" + (setDumpFlag Opt_D_dump_worker_wrapper) + , make_ord_flag defGhcFlag "ddump-rn-trace" + (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-if-trace" + (setDumpFlag Opt_D_dump_if_trace) + , make_ord_flag defGhcFlag "ddump-cs-trace" + (setDumpFlag Opt_D_dump_cs_trace) + , make_ord_flag defGhcFlag "ddump-tc-trace" + (NoArg (do setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) + , make_ord_flag defGhcFlag "ddump-vt-trace" + (setDumpFlag Opt_D_dump_vt_trace) + , make_ord_flag defGhcFlag "ddump-splices" + (setDumpFlag Opt_D_dump_splices) + , make_ord_flag defGhcFlag "dth-dec-file" + (setDumpFlag Opt_D_th_dec_file) + + , make_ord_flag defGhcFlag "ddump-rn-stats" + (setDumpFlag Opt_D_dump_rn_stats) + , make_ord_flag defGhcFlag "ddump-opt-cmm" + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-simpl-stats" + (setDumpFlag Opt_D_dump_simpl_stats) + , make_ord_flag defGhcFlag "ddump-bcos" + (setDumpFlag Opt_D_dump_BCOs) + , make_ord_flag defGhcFlag "dsource-stats" + (setDumpFlag Opt_D_source_stats) + , make_ord_flag defGhcFlag "dverbose-core2core" + (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) + , make_ord_flag defGhcFlag "dverbose-stg2stg" + (setDumpFlag Opt_D_verbose_stg2stg) + , make_ord_flag defGhcFlag "ddump-hi" + (setDumpFlag Opt_D_dump_hi) + , make_ord_flag defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , make_ord_flag defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , make_ord_flag defGhcFlag "ddump-ticked" + (setDumpFlag Opt_D_dump_ticked) + , make_ord_flag defGhcFlag "ddump-mod-cycles" + (setDumpFlag Opt_D_dump_mod_cycles) + , make_ord_flag defGhcFlag "ddump-mod-map" + (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) + , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" + (setDumpFlag Opt_D_dump_view_pattern_commoning) + , make_ord_flag defGhcFlag "ddump-to-file" + (NoArg (setGeneralFlag Opt_DumpToFile)) + , make_ord_flag defGhcFlag "ddump-hi-diffs" + (setDumpFlag Opt_D_dump_hi_diffs) + , make_ord_flag defGhcFlag "ddump-rtti" + (setDumpFlag Opt_D_dump_rtti) + , make_ord_flag defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , make_ord_flag defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , make_ord_flag defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , make_ord_flag defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , make_ord_flag defGhcFlag "dshow-passes" + (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dfaststring-stats" + (NoArg (setGeneralFlag Opt_D_faststring_stats)) + , make_ord_flag defGhcFlag "dno-llvm-mangler" + (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , make_ord_flag defGhcFlag "fast-llvm" + (NoArg (setGeneralFlag Opt_FastLlvm)) -- hidden flag + , make_ord_flag defGhcFlag "dno-typeable-binds" + (NoArg (setGeneralFlag Opt_NoTypeableBinds)) + , make_ord_flag defGhcFlag "ddump-debug" + (setDumpFlag Opt_D_dump_debug) + , make_ord_flag defGhcFlag "ddump-json" + (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) + , make_ord_flag defGhcFlag "dppr-debug" + (setDumpFlag Opt_D_ppr_debug) + , make_ord_flag defGhcFlag "ddebug-output" + (noArg (flip dopt_unset Opt_D_no_debug_output)) + , make_ord_flag defGhcFlag "dno-debug-output" + (setDumpFlag Opt_D_no_debug_output) + + ------ Machine dependent (-m<blah>) stuff --------------------------- + + , make_ord_flag defGhcFlag "msse" (noArg (\d -> + d { sseVersion = Just SSE1 })) + , make_ord_flag defGhcFlag "msse2" (noArg (\d -> + d { sseVersion = Just SSE2 })) + , make_ord_flag defGhcFlag "msse3" (noArg (\d -> + d { sseVersion = Just SSE3 })) + , make_ord_flag defGhcFlag "msse4" (noArg (\d -> + d { sseVersion = Just SSE4 })) + , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> + d { sseVersion = Just SSE42 })) + , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> + d { bmiVersion = Just BMI1 })) + , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> + d { bmiVersion = Just BMI2 })) + , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) + , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) + , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> + d { avx512cd = True })) + , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> + d { avx512er = True })) + , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) + , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> + d { avx512pf = True })) + + ------ Warning opts ------------------------------------------------- + , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Werror" + (NoArg (do { setGeneralFlag Opt_WarnIsError + ; mapM_ setFatalWarningFlag minusWeverythingOpts })) + , make_ord_flag defFlag "Wwarn" + (NoArg (do { unSetGeneralFlag Opt_WarnIsError + ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) + -- Opt_WarnIsError is still needed to pass -Werror + -- to CPP; see runCpp in SysTools + , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + "Use -w or -Wno-everything instead" + , make_ord_flag defFlag "w" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + + -- New-style uniform warning sets + -- + -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything + , make_ord_flag defFlag "Weverything" (NoArg (mapM_ + setWarningFlag minusWeverythingOpts)) + , make_ord_flag defFlag "Wno-everything" + (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) + + , make_ord_flag defFlag "Wall" (NoArg (mapM_ + setWarningFlag minusWallOpts)) + , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ + unSetWarningFlag minusWallOpts)) + + , make_ord_flag defFlag "Wextra" (NoArg (mapM_ + setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ + unSetWarningFlag minusWOpts)) + + , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ + setWarningFlag standardWarnings)) + , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ + unSetWarningFlag standardWarnings)) + + , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ + setWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ + unSetWarningFlag minusWcompatOpts)) + + ------ Plugin flags ------------------------------------------------ + , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , make_ord_flag defGhcFlag "fplugin-trustworthy" + (NoArg (setGeneralFlag Opt_PluginTrustworthy)) + , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) + , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) + , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + + ------ Optimisation flags ------------------------------------------ + , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) + "Use -O0 instead" + , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> + setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + , make_ord_flag defFlag "fbinary-blob-threshold" + (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n })) + + , make_ord_flag defFlag "fmax-relevant-binds" + (intSuffix (\n d -> d { maxRelevantBinds = Just n })) + , make_ord_flag defFlag "fno-max-relevant-binds" + (noArg (\d -> d { maxRelevantBinds = Nothing })) + + , make_ord_flag defFlag "fmax-valid-hole-fits" + (intSuffix (\n d -> d { maxValidHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-valid-hole-fits" + (noArg (\d -> d { maxValidHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-refinement-hole-fits" + (intSuffix (\n d -> d { maxRefHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-refinement-hole-fits" + (noArg (\d -> d { maxRefHoleFits = Nothing })) + , make_ord_flag defFlag "frefinement-level-hole-fits" + (intSuffix (\n d -> d { refLevelHoleFits = Just n })) + , make_ord_flag defFlag "fno-refinement-level-hole-fits" + (noArg (\d -> d { refLevelHoleFits = Nothing })) + + , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" + (noArg id) + "vectors registers are now passed in registers by default." + , make_ord_flag defFlag "fmax-uncovered-patterns" + (intSuffix (\n d -> d { maxUncoveredPatterns = n })) + , make_ord_flag defFlag "fmax-pmcheck-models" + (intSuffix (\n d -> d { maxPmCheckModels = n })) + , make_ord_flag defFlag "fsimplifier-phases" + (intSuffix (\n d -> d { simplPhases = n })) + , make_ord_flag defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d { maxSimplIterations = n })) + , (Deprecated, defFlag "fmax-pmcheck-iterations" + (intSuffixM (\_ d -> + do { deprecate $ "use -fmax-pmcheck-models instead" + ; return d }))) + , make_ord_flag defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d { simplTickFactor = n })) + , make_ord_flag defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d { specConstrThreshold = Just n })) + , make_ord_flag defFlag "fno-spec-constr-threshold" + (noArg (\d -> d { specConstrThreshold = Nothing })) + , make_ord_flag defFlag "fspec-constr-count" + (intSuffix (\n d -> d { specConstrCount = Just n })) + , make_ord_flag defFlag "fno-spec-constr-count" + (noArg (\d -> d { specConstrCount = Nothing })) + , make_ord_flag defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d { specConstrRecursive = n })) + , make_ord_flag defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) + , make_ord_flag defFlag "fno-liberate-case-threshold" + (noArg (\d -> d { liberateCaseThreshold = Nothing })) + , make_ord_flag defFlag "drule-check" + (sepArg (\s d -> d { ruleCheck = Just s })) + , make_ord_flag defFlag "dinline-check" + (sepArg (\s d -> d { inlineCheck = Just s })) + , make_ord_flag defFlag "freduction-depth" + (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) + , make_ord_flag defFlag "fconstraint-solver-iterations" + (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) + , (Deprecated, defFlag "fcontext-stack" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , (Deprecated, defFlag "ftype-function-depth" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , make_ord_flag defFlag "fstrictness-before" + (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) + , make_ord_flag defFlag "ffloat-lam-args" + (intSuffix (\n d -> d { floatLamArgs = Just n })) + , make_ord_flag defFlag "ffloat-all-lams" + (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = True })) + , make_ord_flag defFlag "fno-stg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = False })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + , make_ord_flag defFlag "fblock-layout-weights" + (HasArg (\s -> + upd (\d -> d { cfgWeightInfo = + parseCfgWeights s (cfgWeightInfo d)}))) + , make_ord_flag defFlag "fhistory-size" + (intSuffix (\n d -> d { historySize = n })) + , make_ord_flag defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d {ufCreationThreshold = n})) + , make_ord_flag defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d {ufUseThreshold = n})) + , make_ord_flag defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d {ufFunAppDiscount = n})) + , make_ord_flag defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d {ufDictDiscount = n})) + , make_ord_flag defFlag "funfolding-keeness-factor" + (floatSuffix (\n d -> d {ufKeenessFactor = n})) + , make_ord_flag defFlag "fmax-worker-args" + (intSuffix (\n d -> d {maxWorkerArgs = n})) + , make_ord_flag defGhciFlag "fghci-hist-size" + (intSuffix (\n d -> d {ghciHistSize = n})) + , make_ord_flag defGhcFlag "fmax-inline-alloc-size" + (intSuffix (\n d -> d { maxInlineAllocSize = n })) + , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" + (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) + , make_ord_flag defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) + , make_ord_flag defGhcFlag "dinitial-unique" + (intSuffix (\n d -> d { initialUnique = n })) + , make_ord_flag defGhcFlag "dunique-increment" + (intSuffix (\n d -> d { uniqueIncrement = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , make_dep_flag defGhcFlag "auto-all" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + "Use -fprof-auto instead" + , make_dep_flag defGhcFlag "no-auto-all" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "auto" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + "Use -fprof-auto-exported instead" + , make_dep_flag defGhcFlag "no-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fprof-cafs instead" + , make_dep_flag defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fno-prof-cafs instead" + + -- NEW profiling flags + , make_ord_flag defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , make_ord_flag defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , make_ord_flag defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , make_ord_flag defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , make_ord_flag defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + ------ Compiler flags ----------------------------------------------- + + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) + , make_ord_flag defGhcFlag "fvia-c" (NoArg + (deprecate $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fvia-C" (NoArg + (deprecate $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) + + , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> + d { ghcLink=NoLink }) >> setTarget HscNothing)) + , make_ord_flag defFlag "fbyte-code" + (noArgM $ \dflags -> do + setTarget HscInterpreted + pure $ gopt_set dflags Opt_ByteCode) + , make_ord_flag defFlag "fobject-code" $ NoArg $ do + dflags <- liftEwM getCmdLineState + setTarget $ defaultObjectTarget dflags + + , make_dep_flag defFlag "fglasgow-exts" + (NoArg enableGlasgowExts) "Use individual extensions instead" + , make_dep_flag defFlag "fno-glasgow-exts" + (NoArg disableGlasgowExts) "Use individual extensions instead" + , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) + , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg + disableUnusedBinds) + + ------ Safe Haskell flags ------------------------------------------- + , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) + , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> + d { safeInfer = False })) + , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) + + ------ position independent flags ---------------------------------- + , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC)) + + ------ Debugging flags ---------------------------------------------- + , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) + wWarningFlagsDeps + ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) + wWarningFlagsDeps + ++ [ (NotDeprecated, unrecognisedWarning "W"), + (Deprecated, unrecognisedWarning "fwarn-"), + (Deprecated, unrecognisedWarning "fno-warn-") ] + ++ [ make_ord_flag defFlag "Werror=compat" + (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-error=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wwarn=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps + ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps + ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps + ++ [ make_dep_flag defFlag "XGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures " ++ + "and -XDeriveGeneric for generic programming support.") + , make_dep_flag defFlag "XNoGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures and " ++ + "-XDeriveGeneric for generic programming support.") ] + +-- | This is where we handle unrecognised warning flags. We only issue a warning +-- if -Wunrecognised-warning-flags is set. See #11429 for context. +unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) +unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) + where + action :: String -> EwM (CmdLineP DynFlags) () + action flag = do + f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState + when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ + "unrecognised warning flag: -" ++ prefix ++ flag + +-- See Note [Supporting CLI completion] +package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +package_flags_deps = [ + ------- Packages ---------------------------------------------------- + make_ord_flag defFlag "package-db" + (HasArg (addPkgDbRef . PkgDbPath)) + , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) + , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) + , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) + , make_ord_flag defFlag "global-package-db" + (NoArg (addPkgDbRef GlobalPkgDb)) + , make_ord_flag defFlag "user-package-db" + (NoArg (addPkgDbRef UserPkgDb)) + -- backwards compat with GHC<=7.4 : + , make_dep_flag defFlag "package-conf" + (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + , make_dep_flag defFlag "no-user-package-conf" + (NoArg removeUserPkgDb) "Use -no-user-package-db instead" + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do + upd (setUnitId name)) + -- TODO: Since we JUST deprecated + -- -this-package-key, let's keep this + -- undeprecated for another cycle. + -- Deprecate this eventually. + -- deprecate "Use -this-unit-id instead") + , make_dep_flag defGhcFlag "this-package-key" (HasArg $ upd . setUnitId) + "Use -this-unit-id instead" + , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + , make_ord_flag defFlag "package" (HasArg exposePackage) + , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) + , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) + , make_ord_flag defFlag "package-id" (HasArg exposePackageId) + , make_ord_flag defFlag "hide-package" (HasArg hidePackage) + , make_ord_flag defFlag "hide-all-packages" + (NoArg (setGeneralFlag Opt_HideAllPackages)) + , make_ord_flag defFlag "hide-all-plugin-packages" + (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) + , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) + , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) + , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" + , make_ord_flag defFlag "distrust-all-packages" + (NoArg (setGeneralFlag Opt_DistrustAllPackages)) + , make_ord_flag defFlag "trust" (HasArg trustPackage) + , make_ord_flag defFlag "distrust" (HasArg distrustPackage) + ] + where + setPackageEnv env = upd $ \s -> s { packageEnv = Just env } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) + +-- | Define a new deprecated flag with an effect. +depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecOp name flag act dep = + (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) + +-- | Define a new deprecated flag. +depFlagSpec :: String -> flag -> String + -> (Deprecation, FlagSpec flag) +depFlagSpec name flag dep = depFlagSpecOp name flag nop dep + +-- | Define a new deprecated flag with an effect where the deprecation message +-- depends on the flag value +depFlagSpecOp' :: String + -> flag + -> (TurnOnFlag -> DynP ()) + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpecOp' name flag act dep = + (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) + AllModes) + +-- | Define a new deprecated flag where the deprecation message +-- depends on the flag value +depFlagSpec' :: String + -> flag + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep + + +-- | Define a new deprecated flag where the deprecation message +-- is shown depending on the flag value +depFlagSpecCond :: String + -> flag + -> (TurnOnFlag -> Bool) + -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecCond name flag cond dep = + (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) + AllModes) + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act + HiddenFlag) + +-- | Hide a 'FlagSpec' from being displayed in @--show-options@. +-- +-- This is for example useful for flags that are obsolete, but should not +-- (yet) be deprecated for compatibility reasons. +hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) +hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> (Deprecation, FlagSpec flag) -- ^ Specification of + -- this particular flag + -> (Deprecation, Flag (CmdLineP DynFlags)) +mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) + = (dep, + Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) + +deprecatedForExtension :: String -> TurnOnFlag -> String +deprecatedForExtension lang turn_on + = "use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" + where + flag | turn_on = lang + | otherwise = "No" ++ lang + +useInstead :: String -> String -> TurnOnFlag -> String +useInstead prefix flag turn_on + = "Use " ++ prefix ++ no ++ flag ++ " instead" + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | Find the 'FlagSpec' for a 'WarningFlag'. +flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) +flagSpecOf flag = listToMaybe $ filter check wWarningFlags + where + check fs = flagSpecFlag fs == flag + +-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@ +wWarningFlags :: [FlagSpec WarningFlag] +wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) + +wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] +wWarningFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "alternative-layout-rule-transitional" + Opt_WarnAlternativeLayoutRuleTransitional, + depFlagSpec "auto-orphans" Opt_WarnAutoOrphans + "it has no effect", + flagSpec "cpp-undef" Opt_WarnCPPUndef, + flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, + flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, + flagSpec "deferred-out-of-scope-variables" + Opt_WarnDeferredOutOfScopeVariables, + flagSpec "deprecations" Opt_WarnWarningsDeprecations, + flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, + flagSpec "deriving-defaults" Opt_WarnDerivingDefaults, + flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, + flagSpec "dodgy-exports" Opt_WarnDodgyExports, + flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, + flagSpec "dodgy-imports" Opt_WarnDodgyImports, + flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, + depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints + "it is subsumed by -Wredundant-constraints", + flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, + flagSpec "duplicate-exports" Opt_WarnDuplicateExports, + depFlagSpec "hi-shadowing" Opt_WarnHiShadows + "it is not used, and was never implemented", + flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, + flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, + depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars + "it is now an error", + flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, + flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, + flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, + flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, + flagSpec "identities" Opt_WarnIdentities, + flagSpec "missing-fields" Opt_WarnMissingFields, + flagSpec "missing-import-lists" Opt_WarnMissingImportList, + flagSpec "missing-export-lists" Opt_WarnMissingExportList, + depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures + "it is replaced by -Wmissing-local-signatures", + flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, + flagSpec "missing-methods" Opt_WarnMissingMethods, + flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, + flagSpec "semigroup" Opt_WarnSemigroup, + flagSpec "missing-signatures" Opt_WarnMissingSignatures, + depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures + "it is replaced by -Wmissing-exported-signatures", + flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, + flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, + flagSpec "name-shadowing" Opt_WarnNameShadowing, + flagSpec "noncanonical-monad-instances" + Opt_WarnNonCanonicalMonadInstances, + depFlagSpec "noncanonical-monadfail-instances" + Opt_WarnNonCanonicalMonadInstances + "fail is no longer a method of Monad", + flagSpec "noncanonical-monoid-instances" + Opt_WarnNonCanonicalMonoidInstances, + flagSpec "orphans" Opt_WarnOrphans, + flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, + flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, + flagSpec "missed-specialisations" Opt_WarnMissedSpecs, + flagSpec "missed-specializations" Opt_WarnMissedSpecs, + flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, + flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, + flagSpec' "safe" Opt_WarnSafe setWarnSafe, + flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, + flagSpec "inferred-safe-imports" Opt_WarnInferredSafeImports, + flagSpec "missing-safe-haskell-mode" Opt_WarnMissingSafeHaskellMode, + flagSpec "tabs" Opt_WarnTabs, + flagSpec "type-defaults" Opt_WarnTypeDefaults, + flagSpec "typed-holes" Opt_WarnTypedHoles, + flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, + flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, + flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, + flagSpec "unsupported-calling-conventions" + Opt_WarnUnsupportedCallingConventions, + flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, + flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib, + flagSpec "unticked-promoted-constructors" + Opt_WarnUntickedPromotedConstructors, + flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, + flagSpec "unused-foralls" Opt_WarnUnusedForalls, + flagSpec "unused-imports" Opt_WarnUnusedImports, + flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, + flagSpec "unused-matches" Opt_WarnUnusedMatches, + flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, + flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, + flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, + flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, + flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, + flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, + flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, + flagSpec "missing-pattern-synonym-signatures" + Opt_WarnMissingPatternSynonymSignatures, + flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies, + flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, + flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, + flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, + flagSpec "star-binder" Opt_WarnStarBinder, + flagSpec "star-is-type" Opt_WarnStarIsType, + depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang + "bang patterns can no longer be written with a space", + flagSpec "partial-fields" Opt_WarnPartialFields, + flagSpec "prepositive-qualified-module" + Opt_WarnPrepositiveQualifiedModule, + flagSpec "unused-packages" Opt_WarnUnusedPackages, + flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports + ] + +-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ +negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +negatableFlagsDeps = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@ +dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +dFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, + depFlagSpec' "ppr-ticks" Opt_PprShowTicks + (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "suppress-ticks" Opt_SuppressTicks, + depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts + (useInstead "-d" "suppress-stg-exts"), + flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + flagSpec "suppress-coercions" Opt_SuppressCoercions, + flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, + flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-timestamps" Opt_SuppressTimestamps, + flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, + flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, + flagSpec "suppress-uniques" Opt_SuppressUniques, + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds + ] + +-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = map snd fFlagsDeps + +fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +fFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "asm-shortcutting" Opt_AsmShortcutting, + flagGhciSpec "break-on-error" Opt_BreakOnError, + flagGhciSpec "break-on-exception" Opt_BreakOnException, + flagSpec "building-cabal-package" Opt_BuildingCabalPackage, + flagSpec "call-arity" Opt_CallArity, + flagSpec "exitification" Opt_Exitification, + flagSpec "case-merge" Opt_CaseMerge, + flagSpec "case-folding" Opt_CaseFolding, + flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cse" Opt_CSE, + flagSpec "stg-cse" Opt_StgCSE, + flagSpec "stg-lift-lams" Opt_StgLiftLams, + flagSpec "cpr-anal" Opt_CprAnal, + flagSpec "defer-diagnostics" Opt_DeferDiagnostics, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + flagSpec "defer-typed-holes" Opt_DeferTypedHoles, + flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, + flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, + flagSpec "do-eta-reduction" Opt_DoEtaReduction, + flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, + flagSpec "error-spans" Opt_ErrorSpans, + flagSpec "excess-precision" Opt_ExcessPrecision, + flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, + flagSpec "external-interpreter" Opt_ExternalInterpreter, + flagSpec "flat-cache" Opt_FlatCache, + flagSpec "float-in" Opt_FloatIn, + flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, + flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, + flagSpec "full-laziness" Opt_FullLaziness, + flagSpec "fun-to-thunk" Opt_FunToThunk, + flagSpec "gen-manifest" Opt_GenManifest, + flagSpec "ghci-history" Opt_GhciHistory, + flagSpec "ghci-leak-check" Opt_GhciLeakCheck, + flagSpec "validate-ide-info" Opt_ValidateHie, + flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, + flagGhciSpec "no-it" Opt_NoIt, + flagSpec "ghci-sandbox" Opt_GhciSandbox, + flagSpec "helpful-errors" Opt_HelpfulErrors, + flagSpec "hpc" Opt_Hpc, + flagSpec "ignore-asserts" Opt_IgnoreAsserts, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "keep-going" Opt_KeepGoing, + flagSpec "kill-absence" Opt_KillAbsence, + flagSpec "kill-one-shot" Opt_KillOneShot, + flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, + flagSpec "liberate-case" Opt_LiberateCase, + flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, + flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, + flagSpec "loopification" Opt_Loopification, + flagSpec "block-layout-cfg" Opt_CfgBlocklayout, + flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, + flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, + flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, + flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, + flagSpec "prof-count-entries" Opt_ProfCountEntries, + flagSpec "regs-graph" Opt_RegsGraph, + flagSpec "regs-iterative" Opt_RegsIterative, + depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "-f" "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "spec-constr-keen" Opt_SpecConstrKeen, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialize" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, + flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, + flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + flagSpec "use-rpaths" Opt_RPath, + flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-ide-info" Opt_WriteHie, + flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, + flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, + flagSpec "version-macros" Opt_VersionMacros, + flagSpec "worker-wrapper" Opt_WorkerWrapper, + flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, + flagSpec "catch-bottoms" Opt_CatchBottoms, + flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, + flagSpec "num-constant-folding" Opt_NumConstantFolding, + flagSpec "show-warning-groups" Opt_ShowWarnGroups, + flagSpec "hide-source-paths" Opt_HideSourcePaths, + flagSpec "show-loaded-modules" Opt_ShowLoadedModules, + flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, + flagSpec "keep-cafs" Opt_KeepCAFs + ] + ++ fHoleFlags + +-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or +-- the valid hole fits in that message. See Note [Valid hole fits include ...] +-- in the TcHoleErrors module. These flags can all be reversed with +-- @-fno-\<blah\>@ +fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] +fHoleFlags = [ + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits + (useInstead "-f" "show-valid-hole-fits"), + flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, + -- Sorting settings + flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, + flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, + flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, + flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, + -- Output format settings + flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, + flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, + flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, + flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, + flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, + flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, + flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits + ] + +-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ +fLangFlags :: [FlagSpec LangExt.Extension] +fLangFlags = map snd fLangFlagsDeps + +fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +fLangFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + depFlagSpecOp' "th" LangExt.TemplateHaskell + checkTemplateHaskellOk + (deprecatedForExtension "TemplateHaskell"), + depFlagSpec' "fi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "ffi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "arrows" LangExt.Arrows + (deprecatedForExtension "Arrows"), + depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + depFlagSpec' "bang-patterns" LangExt.BangPatterns + (deprecatedForExtension "BangPatterns"), + depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds + (deprecatedForExtension "MonoPatBinds"), + depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + depFlagSpec' "implicit-params" LangExt.ImplicitParams + (deprecatedForExtension "ImplicitParams"), + depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map (flagSpecName . snd) languageFlagsDeps + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps + +supportedExtensions :: PlatformMini -> [String] +supportedExtensions targetPlatformMini = concatMap toFlagSpecNamePair xFlags + where + toFlagSpecNamePair flg + -- IMPORTANT! Make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the + -- box. See also GHC #11102 and #16331 for more details about + -- the rationale + | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] + | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] + | otherwise = [name, noName] + where + isAIX = platformMini_os targetPlatformMini == OSAIX + noName = "No" ++ name + name = flagSpecName flg + +supportedLanguagesAndExtensions :: PlatformMini -> [String] +supportedLanguagesAndExtensions targetPlatformMini = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions targetPlatformMini + +-- | These -X<blah> flags cannot be reversed with -XNo<blah> +languageFlagsDeps :: [(Deprecation, FlagSpec Language)] +languageFlagsDeps = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010 + ] + +-- | 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. +safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] +safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X<blah> flags can all be reversed with -XNo<blah> +xFlags :: [FlagSpec LangExt.Extension] +xFlags = map snd xFlagsDeps + +xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +xFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- See Note [Adding a language extension] +-- Please keep the list of flags below sorted alphabetically + flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, + flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, + flagSpec "AlternativeLayoutRuleTransitional" + LangExt.AlternativeLayoutRuleTransitional, + flagSpec "Arrows" LangExt.Arrows, + depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable + id + ("Typeable instances are created automatically " ++ + "for all types since GHC 8.2."), + flagSpec "BangPatterns" LangExt.BangPatterns, + flagSpec "BinaryLiterals" LangExt.BinaryLiterals, + flagSpec "CApiFFI" LangExt.CApiFFI, + flagSpec "CPP" LangExt.Cpp, + flagSpec "CUSKs" LangExt.CUSKs, + flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, + flagSpec "ConstraintKinds" LangExt.ConstraintKinds, + flagSpec "DataKinds" LangExt.DataKinds, + depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts + id + ("It was widely considered a misfeature, " ++ + "and has been removed from the Haskell language."), + flagSpec "DefaultSignatures" LangExt.DefaultSignatures, + flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, + flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, + flagSpec "DeriveFoldable" LangExt.DeriveFoldable, + flagSpec "DeriveFunctor" LangExt.DeriveFunctor, + flagSpec "DeriveGeneric" LangExt.DeriveGeneric, + flagSpec "DeriveLift" LangExt.DeriveLift, + flagSpec "DeriveTraversable" LangExt.DeriveTraversable, + flagSpec "DerivingStrategies" LangExt.DerivingStrategies, + flagSpec "DerivingVia" LangExt.DerivingVia, + flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, + flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, + flagSpec "BlockArguments" LangExt.BlockArguments, + depFlagSpec' "DoRec" LangExt.RecursiveDo + (deprecatedForExtension "RecursiveDo"), + flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, + flagSpec "EmptyCase" LangExt.EmptyCase, + flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, + flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, + flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, + flagSpec "ExplicitForAll" LangExt.ExplicitForAll, + flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, + flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, + flagSpec "FlexibleContexts" LangExt.FlexibleContexts, + flagSpec "FlexibleInstances" LangExt.FlexibleInstances, + flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, + flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, + flagSpec "GADTSyntax" LangExt.GADTSyntax, + flagSpec "GADTs" LangExt.GADTs, + flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, + flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec "ImplicitParams" LangExt.ImplicitParams, + flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, + flagSpec "ImportQualifiedPost" LangExt.ImportQualifiedPost, + flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, + flagSpec' "IncoherentInstances" LangExt.IncoherentInstances + setIncoherentInsts, + flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, + flagSpec "InstanceSigs" LangExt.InstanceSigs, + flagSpec "ApplicativeDo" LangExt.ApplicativeDo, + flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, + flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, + flagSpec "KindSignatures" LangExt.KindSignatures, + flagSpec "LambdaCase" LangExt.LambdaCase, + flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, + flagSpec "MagicHash" LangExt.MagicHash, + flagSpec "MonadComprehensions" LangExt.MonadComprehensions, + depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring + "MonadFailDesugaring is now the default behavior", + flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, + depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds + id + "Experimental feature now removed; has no effect", + flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, + flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, + flagSpec "MultiWayIf" LangExt.MultiWayIf, + flagSpec "NumericUnderscores" LangExt.NumericUnderscores, + flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, + flagSpec "NamedFieldPuns" LangExt.RecordPuns, + flagSpec "NamedWildCards" LangExt.NamedWildCards, + flagSpec "NegativeLiterals" LangExt.NegativeLiterals, + flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, + flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, + depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses + (deprecatedForExtension "MultiParamTypeClasses"), + flagSpec "NumDecimals" LangExt.NumDecimals, + depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances + setOverlappingInsts + "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", + flagSpec "OverloadedLabels" LangExt.OverloadedLabels, + flagSpec "OverloadedLists" LangExt.OverloadedLists, + flagSpec "OverloadedStrings" LangExt.OverloadedStrings, + flagSpec "PackageImports" LangExt.PackageImports, + flagSpec "ParallelArrays" LangExt.ParallelArrays, + flagSpec "ParallelListComp" LangExt.ParallelListComp, + flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, + flagSpec "PatternGuards" LangExt.PatternGuards, + depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + flagSpec "PatternSynonyms" LangExt.PatternSynonyms, + flagSpec "PolyKinds" LangExt.PolyKinds, + flagSpec "PolymorphicComponents" LangExt.RankNTypes, + flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, + flagSpec "PostfixOperators" LangExt.PostfixOperators, + flagSpec "QuasiQuotes" LangExt.QuasiQuotes, + flagSpec "Rank2Types" LangExt.RankNTypes, + flagSpec "RankNTypes" LangExt.RankNTypes, + flagSpec "RebindableSyntax" LangExt.RebindableSyntax, + depFlagSpec' "RecordPuns" LangExt.RecordPuns + (deprecatedForExtension "NamedFieldPuns"), + flagSpec "RecordWildCards" LangExt.RecordWildCards, + flagSpec "RecursiveDo" LangExt.RecursiveDo, + flagSpec "RelaxedLayout" LangExt.RelaxedLayout, + depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec + not + "You can't turn off RelaxedPolyRec any more", + flagSpec "RoleAnnotations" LangExt.RoleAnnotations, + flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, + flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, + flagSpec "StarIsType" LangExt.StarIsType, + flagSpec "StaticPointers" LangExt.StaticPointers, + flagSpec "Strict" LangExt.Strict, + flagSpec "StrictData" LangExt.StrictData, + flagSpec' "TemplateHaskell" LangExt.TemplateHaskell + checkTemplateHaskellOk, + flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, + flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures, + flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, + flagSpec "TransformListComp" LangExt.TransformListComp, + flagSpec "TupleSections" LangExt.TupleSections, + flagSpec "TypeApplications" LangExt.TypeApplications, + flagSpec "TypeInType" LangExt.TypeInType, + flagSpec "TypeFamilies" LangExt.TypeFamilies, + flagSpec "TypeOperators" LangExt.TypeOperators, + flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, + flagSpec "UnboxedTuples" LangExt.UnboxedTuples, + flagSpec "UnboxedSums" LangExt.UnboxedSums, + flagSpec "UndecidableInstances" LangExt.UndecidableInstances, + flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, + flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, + flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, + flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes, + flagSpec "ViewPatterns" LangExt.ViewPatterns + ] + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_DiagnosticsShowCaret, + Opt_EmbedManifest, + Opt_FlatCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_HelpfulErrors, + Opt_KeepHiFiles, + Opt_KeepOFiles, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_RPath, + Opt_SharedImplib, + Opt_SimplPreInlining, + Opt_VersionMacros + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + ++ default_PIC platform + + ++ concatMap (wayGeneralFlags platform) (defaultWays settings) + ++ validHoleFitDefaults + + where platform = sTargetPlatform settings + +-- | These are the default settings for the display and sorting of valid hole +-- fits in typed-hole error messages. See Note [Valid hole fits include ...] + -- in the TcHoleErrors module. +validHoleFitDefaults :: [GeneralFlag] +validHoleFitDefaults + = [ Opt_ShowTypeAppOfHoleFits + , Opt_ShowTypeOfHoleFits + , Opt_ShowProvOfHoleFits + , Opt_ShowMatchesOfHoleFits + , Opt_ShowValidHoleFits + , Opt_SortValidHoleFits + , Opt_SortBySizeHoleFits + , Opt_ShowHoleConstraints ] + + +validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +validHoleFitsImpliedGFlags + = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] + +default_PIC :: Platform -> [GeneralFlag] +default_PIC platform = + case (platformOS platform, platformArch platform) of + (OSDarwin, ArchX86_64) -> [Opt_PIC] + (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in + -- OpenBSD since 5.3 release + -- (1 May 2013) we need to + -- always generate PIC. See + -- #10597 for more + -- information. + _ -> [] + +-- General flags that are switched on/off when other general flags are switched +-- on +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) + ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ] ++ validHoleFitsImpliedGFlags + +-- General flags that are switched on/off when other general flags are switched +-- off +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) + , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) + , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) + , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) + , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) + + , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! + + , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) + + , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) + , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) + , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) + + , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures + , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (LangExt.TypeInType, turnOn, LangExt.DataKinds) + , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) + , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) + + -- Standalone kind signatures are a replacement for CUSKs. + , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) + + , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) + , (LangExt.Strict, turnOn, LangExt.StrictData) + ] + +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- Programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, but making TypeOperators imply +-- NoStarIsType caused too much breakage on Hackage. +-- + +-- Note [Documenting optimisation flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of flags enabled for particular optimisation levels +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-optimisation.rst +-- +-- Make sure to note whether a flag is implied by -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +-- Default settings of flags, before any command-line overrides +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] + , ([0,1,2], Opt_DmdTxDictSel) + , ([0,1,2], Opt_LlvmTBAA) + + , ([0], Opt_IgnoreInterfacePragmas) + , ([0], Opt_OmitInterfacePragmas) + + , ([1,2], Opt_CallArity) + , ([1,2], Opt_Exitification) + , ([1,2], Opt_CaseMerge) + , ([1,2], Opt_CaseFolding) + , ([1,2], Opt_CmmElimCommonBlocks) + , ([2], Opt_AsmShortcutting) + , ([1,2], Opt_CmmSink) + , ([1,2], Opt_CSE) + , ([1,2], Opt_StgCSE) + , ([2], Opt_StgLiftLams) + + , ([1,2], Opt_EnableRewriteRules) + -- Off for -O0. Otherwise we desugar list literals + -- to 'build' but don't run the simplifier passes that + -- would rewrite them back to cons cells! This seems + -- silly, and matters for the GHCi debugger. + + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_CfgBlocklayout) -- Experimental + + , ([1,2], Opt_Specialise) + , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + , ([1,2], Opt_CprAnal) + , ([1,2], Opt_WorkerWrapper) + , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + ] + + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +-- Note [Documenting warning flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of warning enabled by default +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-warnings.rst + +-- | Warning groups. +-- +-- As all warnings are in the Weverything set, it is ignored when +-- displaying to the user which group a warning is in. +warningGroups :: [(String, [WarningFlag])] +warningGroups = + [ ("compat", minusWcompatOpts) + , ("unused-binds", unusedBindsFlags) + , ("default", standardWarnings) + , ("extra", minusWOpts) + , ("all", minusWallOpts) + , ("everything", minusWeverythingOpts) + ] + +-- | Warning group hierarchies, where there is an explicit inclusion +-- relation. +-- +-- Each inner list is a hierarchy of warning groups, ordered from +-- smallest to largest, where each group is a superset of the one +-- before it. +-- +-- Separating this from 'warningGroups' allows for multiple +-- hierarchies with no inherent relation to be defined. +-- +-- The special-case Weverything group is not included. +warningHierarchies :: [[String]] +warningHierarchies = hierarchies ++ map (:[]) rest + where + hierarchies = [["default", "extra", "all"]] + rest = filter (`notElem` "everything" : concat hierarchies) $ + map fst warningGroups + +-- | Find the smallest group in every hierarchy which a warning +-- belongs to, excluding Weverything. +smallestGroups :: WarningFlag -> [String] +smallestGroups flag = mapMaybe go warningHierarchies where + -- Because each hierarchy is arranged from smallest to largest, + -- the first group we find in a hierarchy which contains the flag + -- is the smallest. + go (group:rest) = fromMaybe (go rest) $ do + flags <- lookup group warningGroups + guard (flag `elem` flags) + pure (Just group) + go [] = Nothing + +-- | Warnings enabled unless specified otherwise +standardWarnings :: [WarningFlag] +standardWarnings -- see Note [Documenting warning flags] + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, + Opt_WarnDeprecatedFlags, + Opt_WarnDeferredTypeErrors, + Opt_WarnTypedHoles, + Opt_WarnDeferredOutOfScopeVariables, + Opt_WarnPartialTypeSignatures, + Opt_WarnUnrecognisedPragmas, + Opt_WarnDuplicateExports, + Opt_WarnDerivingDefaults, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnWrongDoBind, + Opt_WarnUnsupportedCallingConventions, + Opt_WarnDodgyForeignImports, + Opt_WarnInlineRuleShadowing, + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion, + Opt_WarnMissedExtraSharedLib, + Opt_WarnTabs, + Opt_WarnUnrecognisedWarningFlags, + Opt_WarnSimplifiableClassConstraints, + Opt_WarnStarBinder, + Opt_WarnInaccessibleCode, + Opt_WarnSpaceAfterBang + ] + +-- | Things you get with -W +minusWOpts :: [WarningFlag] +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedTopBinds, + Opt_WarnUnusedLocalBinds, + Opt_WarnUnusedPatternBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedForalls, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, + Opt_WarnDodgyImports, + Opt_WarnUnbangedStrictPatterns + ] + +-- | Things you get with -Wall +minusWallOpts :: [WarningFlag] +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSignatures, + Opt_WarnHiShadows, + Opt_WarnOrphans, + Opt_WarnUnusedDoBind, + Opt_WarnTrustworthySafe, + Opt_WarnUntickedPromotedConstructors, + Opt_WarnMissingPatternSynonymSignatures, + Opt_WarnUnusedRecordWildcards, + Opt_WarnRedundantRecordWildcards, + Opt_WarnStarIsType + ] + +-- | Things you get with -Weverything, i.e. *all* known warnings flags +minusWeverythingOpts :: [WarningFlag] +minusWeverythingOpts = [ toEnum 0 .. ] + +-- | Things you get with -Wcompat. +-- +-- This is intended to group together warnings that will be enabled by default +-- at some point in the future, so that library authors eager to make their +-- code future compatible to fix issues before they even generate warnings. +minusWcompatOpts :: [WarningFlag] +minusWcompatOpts + = [ Opt_WarnMissingMonadFailInstances + , Opt_WarnSemigroup + , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnStarIsType + , Opt_WarnCompatUnqualifiedImports + ] + +enableUnusedBinds :: DynP () +enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags + +disableUnusedBinds :: DynP () +disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags + +-- Things you get with -Wunused-binds +unusedBindsFlags :: [WarningFlag] +unusedBindsFlags = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls + mapM_ unSetExtensionFlag glasgowExtsFlags + +-- Please keep what_glasgow_exts_does.rst up to date with this list +glasgowExtsFlags :: [LangExt.Extension] +glasgowExtsFlags = [ + LangExt.ConstrainedClassMethods + , LangExt.DeriveDataTypeable + , LangExt.DeriveFoldable + , LangExt.DeriveFunctor + , LangExt.DeriveGeneric + , LangExt.DeriveTraversable + , LangExt.EmptyDataDecls + , LangExt.ExistentialQuantification + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.ForeignFunctionInterface + , LangExt.FunctionalDependencies + , LangExt.GeneralizedNewtypeDeriving + , LangExt.ImplicitParams + , LangExt.KindSignatures + , LangExt.LiberalTypeSynonyms + , LangExt.MagicHash + , LangExt.MultiParamTypeClasses + , LangExt.ParallelListComp + , LangExt.PatternGuards + , LangExt.PostfixOperators + , LangExt.RankNTypes + , LangExt.RecursiveDo + , LangExt.ScopedTypeVariables + , LangExt.StandaloneDeriving + , LangExt.TypeOperators + , LangExt.TypeSynonymInstances + , LangExt.UnboxedTuples + , LangExt.UnicodeSyntax + , LangExt.UnliftedFFITypes ] + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt + +-- | Was the runtime system built with profiling enabled? +rtsIsProfiled :: Bool +rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 + +-- Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt + +dynamicGhc :: Bool +dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +checkTemplateHaskellOk _turn_on + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffixM fn = IntSuffix (\n -> updM (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWay :: Way -> DynP () +addWay w = upd (addWay' w) + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = let platform = targetPlatform dflags0 + dflags1 = dflags0 { ways = w : ways dflags0 } + dflags2 = foldr setGeneralFlag' dflags1 + (wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (wayUnsetGeneralFlags platform w) + in dflags3 + +removeWayDyn :: DynP () +removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedOffGFlags, f' == f ] + -- In general, when you un-set f, we don't un-set the things it implies. + -- There are however some exceptions, e.g., -fno-strictness implies + -- -fno-worker-wrapper. + -- + -- NB: use unSetGeneralFlag' recursively, in case the implied off flags + -- imply further flags. + +-------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () +setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) +unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) + +setWErrorFlag :: WarningFlag -> DynP () +setWErrorFlag flag = + do { setWarningFlag flag + ; setFatalWarningFlag flag } + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d + | (f', turn_on, d) <- impliedXFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setExtensionFlag recursively, in case the implied flags + -- implies further flags + +unSetExtensionFlag' f dflags = xopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- +alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags +alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) } + +alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags +alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs, + Opt_D_no_debug_output] + +forceRecompile :: DynP () +-- Whenever we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerboseCore2Core :: DynP () +setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +setDebugLevel :: Maybe Int -> DynP () +setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) + +data PkgDbRef + = GlobalPkgDb + | UserPkgDb + | PkgDbPath FilePath + deriving Eq + +addPkgDbRef :: PkgDbRef -> DynP () +addPkgDbRef p = upd $ \s -> + s { packageDBFlags = PackageDB p : packageDBFlags s } + +removeUserPkgDb :: DynP () +removeUserPkgDb = upd $ \s -> + s { packageDBFlags = NoUserPackageDB : packageDBFlags s } + +removeGlobalPkgDb :: DynP () +removeGlobalPkgDb = upd $ \s -> + s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } + +clearPkgDb :: DynP () +clearPkgDb = upd $ \s -> + s { packageDBFlags = ClearPackageDBs : packageDBFlags s } + +parsePackageFlag :: String -- the flag + -> ReadP PackageArg -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag flag arg_parse str + = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where doc = flag ++ " " ++ str + parse = do + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg + ( do _ <- tok $ string "with" + fmap (mk_expose . ModRenaming True) parseRns + <++ fmap (mk_expose . ModRenaming False) parseRns + <++ return (mk_expose (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, hidePackage, + exposePluginPackage, exposePluginPackageId, + ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) +exposePluginPackage p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) +exposePluginPackageId p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) + +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitIdArg :: ReadP PackageArg +parseUnitIdArg = + fmap UnitIdArg parseUnitId + +setUnitId :: String -> DynFlags -> DynFlags +setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } + +-- | Given a 'ModuleName' of a signature in the home library, find +-- out how it is instantiated. E.g., the canonical form of +-- A in @p[A=q[]:A]@ is @q[]:A@. +canonicalizeHomeModule :: DynFlags -> ModuleName -> Module +canonicalizeHomeModule dflags mod_name = + case lookup mod_name (thisUnitIdInsts dflags) of + Nothing -> mkModule (thisPackage dflags) mod_name + Just mod -> mod + +canonicalizeModuleIfHome :: DynFlags -> Module -> Module +canonicalizeModuleIfHome dflags mod + = if thisPackage dflags == moduleUnitId mod + then canonicalizeHomeModule dflags (moduleName mod) + else mod + +-- If we're linking a binary, then only targets that produce object +-- code are allowed (requests for other target types are ignored). +setTarget :: HscTarget -> DynP () +setTarget l = upd $ \ dfs -> + if ghcLink dfs /= LinkBinary || isObjectTarget l + then dfs{ hscTarget = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjTarget :: HscTarget -> DynP () +setObjTarget l = updM set + where + set dflags + | isObjectTarget (hscTarget dflags) + = return $ dflags { hscTarget = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +checkOptLevel :: Int -> DynFlags -> Either String DynFlags +checkOptLevel n dflags + | hscTarget dflags == HscInterpreted && n > 0 + = Left "-O conflicts with --interactive; -O ignored." + | otherwise + = Right dflags + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_fn) && isLower (head main_fn) + -- The arg looked like "Foo.Bar.baz" + = upd $ \d -> d { mainFunIs = Just main_fn, + mainModIs = mkModule mainUnitId (mkModuleName main_mod) } + + | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d { mainFunIs = Just arg } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + +-- ----------------------------------------------------------------------------- +-- Load dynflags from environment files. + +setFlagsFromEnvFile :: FilePath -> String -> DynP () +setFlagsFromEnvFile envfile content = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + +parseEnvFile :: FilePath -> String -> DynP () +parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgDb + ["global-package-db"] -> addPkgDbRef GlobalPkgDb + ["user-package-db"] -> addPkgDbRef UserPkgDb + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#if !defined(mingw32_HOST_OS) +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#if !defined(mingw32_HOST_OS) + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- "<Drive>:/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir } + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags = pieOpts ++ picOpts + where + picOpts = + case platformOS (targetPlatform dflags) of + OSDarwin + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- objects, but can't without -fPIC. See + -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> + ["-fPIC", "-U__PIC__", "-D__PIC__"] + -- gcc may be configured to have PIC on by default, let's be + -- explicit here, see #15847 + | otherwise -> ["-fno-PIC"] + + pieOpts + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] + | otherwise = [] + + +{- +Note [No PIE while linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by +default in their gcc builds. This is incompatible with -r as it implies that we +are producing an executable. Consequently, we must manually pass -no-pie to gcc +when joining object files or linking dynamic libraries. Unless, of course, the +user has explicitly requested a PIE executable with -pie. See #12759. +-} + +picPOpts :: DynFlags -> [String] +picPOpts dflags + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), + ("Object splitting supported", showBool False), + ("Have native code generator", showBool $ platformMisc_ghcWithNativeCodeGen $ platformMisc dflags), + -- Whether or not we support @-dynamic-too@ + ("Support dynamic-too", showBool $ not isWindows), + -- Whether or not we support the @-j@ flag with @--make@. + ("Support parallel --make", "YES"), + -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in + -- installed package info. + ("Support reexported-modules", "YES"), + -- Whether or not we support extended @-package foo (Foo)@ syntax. + ("Support thinning and renaming package flags", "YES"), + -- Whether or not we support Backpack. + ("Support Backpack", "YES"), + -- If true, we require that the 'id' field in installed package info + -- match what is passed to the @-this-unit-id@ flag for modules + -- built in it + ("Requires unified installed package IDs", "YES"), + -- Whether or not we support the @-this-package-key@ flag. Prefer + -- "Uses unit IDs" over it. + ("Uses package keys", "YES"), + -- Whether or not we support the @-this-unit-id@ flag + ("Uses unit IDs", "YES"), + -- Whether or not GHC compiles libraries as dynamic by default + ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), + -- Whether or not GHC was compiled using -dynamic + ("GHC Dynamic", showBool dynamicGhc), + -- Whether or not GHC was compiled using -prof + ("GHC Profiled", showBool rtsIsProfiled), + ("Debug on", showBool debugIsOn), + ("LibDir", topDir dflags), + -- The path of the global package database used by GHC + ("Global Package DB", globalPackageDatabasePath dflags) + ] + where + showBool True = "YES" + showBool False = "NO" + isWindows = platformOS (targetPlatform dflags) == OSMinGW32 + expandDirectories :: FilePath -> Maybe FilePath -> String -> String + expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd + +-- Produced by deriveConstants +#include "GHCConstantsHaskellWrappers.hs" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 + +wordAlignment :: DynFlags -> Alignment +wordAlignment dflags = alignmentOf (wORD_SIZE dflags) + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + +-- Might be worth caching these in targetPlatform? +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer +tARGET_MIN_INT dflags + = case platformWordSize (targetPlatform dflags) of + PW4 -> toInteger (minBound :: Int32) + PW8 -> toInteger (minBound :: Int64) +tARGET_MAX_INT dflags + = case platformWordSize (targetPlatform dflags) of + PW4 -> toInteger (maxBound :: Int32) + PW8 -> toInteger (maxBound :: Int64) +tARGET_MAX_WORD dflags + = case platformWordSize (targetPlatform dflags) of + PW4 -> toInteger (maxBound :: Word32) + PW8 -> toInteger (maxBound :: Word64) + + +{- ----------------------------------------------------------------------------- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). +-} + +-- | Resolve any internal inconsistencies in a set of 'DynFlags'. +-- Returns the consistent 'DynFlags' as well as a list of warnings +-- to report to the user. +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) +-- Whenever makeDynFlagsConsistent does anything, it starts over, to +-- ensure that a later change doesn't invalidate an earlier check. +-- Be careful not to introduce potential loops! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + | hscTarget dflags == HscC && + not (platformUnregisterised (targetPlatform dflags)) + = if platformMisc_ghcWithNativeCodeGen $ platformMisc dflags + then let dflags' = dflags { hscTarget = HscAsm } + warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" + in loop dflags' warn + else let dflags' = dflags { hscTarget = HscLlvm } + warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" + in loop dflags' warn + | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted + = let dflags' = gopt_unset dflags Opt_Hpc + warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + in loop dflags' warn + | hscTarget dflags `elem` [HscAsm, HscLlvm] && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { hscTarget = HscC }) + "Compiler unregisterised, so compiling via C" + | hscTarget dflags == HscAsm && + not (platformMisc_ghcWithNativeCodeGen $ platformMisc dflags) + = let dflags' = dflags { hscTarget = HscLlvm } + warn = "No native code generator, so using LLVM" + in loop dflags' warn + | not (osElfTarget os) && gopt Opt_PIE dflags + = loop (gopt_unset dflags Opt_PIE) + "Position-independent only supported on ELF platforms" + | os == OSDarwin && + arch == ArchX86_64 && + not (gopt Opt_PIC dflags) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + | Left err <- checkOptLevel (optLevel dflags) dflags + = loop (updOptLevel 0 dflags) err + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , rtsIsProfiled + , isObjectTarget (hscTarget dflags) + , WayProf `notElem` ways dflags + = loop dflags{ways = WayProf : ways dflags} + "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + + | otherwise = (dflags, []) + where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") + loop updated_dflags warning + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws) -> (dflags', L loc warning : ws) + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + +-------------------------------------------------------------------------- +-- Do not use unsafeGlobalDynFlags! +-- +-- unsafeGlobalDynFlags is a hack, necessary because we need to be able +-- to show SDocs when tracing, but we don't always have DynFlags +-- available. +-- +-- Do not use it if you can help it. You may get the wrong value, or this +-- panic! + +-- | This is the value that 'unsafeGlobalDynFlags' takes before it is +-- initialized. +defaultGlobalDynFlags :: DynFlags +defaultGlobalDynFlags = + (defaultDynFlags settings llvmConfig) { verbosity = 2 } + where + settings = panic "v_unsafeGlobalDynFlags: settings not initialised" + llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised" + +#if GHC_STAGE < 2 +GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) +#else +SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags + , getOrSetLibHSghcGlobalDynFlags + , "getOrSetLibHSghcGlobalDynFlags" + , defaultGlobalDynFlags + , DynFlags ) +#endif + +unsafeGlobalDynFlags :: DynFlags +unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags + +-- ----------------------------------------------------------------------------- +-- SSE and AVX + +-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to +-- check if SSE is enabled, we might have x86-64 imply the -msse2 +-- flag. + +data SseVersion = SSE1 + | SSE2 + | SSE3 + | SSE4 + | SSE42 + deriving (Eq, Ord) + +isSseEnabled :: DynFlags -> Bool +isSseEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + ArchX86 -> True + _ -> False + +isSse2Enabled :: DynFlags -> Bool +isSse2Enabled dflags = case platformArch (targetPlatform dflags) of + -- We Assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + ArchX86_64 -> True + ArchX86 -> True + _ -> False + + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +isAvx512pfEnabled :: DynFlags -> Bool +isAvx512pfEnabled dflags = avx512pf dflags + +-- ----------------------------------------------------------------------------- +-- BMI2 + +data BmiVersion = BMI1 + | BMI2 + deriving (Eq, Ord) + +isBmiEnabled :: DynFlags -> Bool +isBmiEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI1 + ArchX86 -> bmiVersion dflags >= Just BMI1 + _ -> False + +isBmi2Enabled :: DynFlags -> Bool +isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI2 + ArchX86 -> bmiVersion dflags >= Just BMI2 + _ -> False + +-- ----------------------------------------------------------------------------- +-- Linker/compiler information + +-- LinkerInfo contains any extra options needed by the system linker. +data LinkerInfo + = GnuLD [Option] + | GnuGold [Option] + | LlvmLLD [Option] + | DarwinLD [Option] + | SolarisLD [Option] + | AixLD [Option] + | UnknownLD + deriving Eq + +-- CompilerInfo tells us which C compiler we're using +data CompilerInfo + = GCC + | Clang + | AppleClang + | AppleClang51 + | UnknownCC + deriving Eq + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () + +-- ----------------------------------------------------------------------------- +-- Types for managing temporary files. +-- +-- these are here because FilesToClean is used in DynFlags + +-- | A collection of files that must be deleted before ghc exits. +-- The current collection +-- is stored in an IORef in DynFlags, 'filesToClean'. +data FilesToClean = FilesToClean { + ftcGhcSession :: !(Set FilePath), + -- ^ Files that will be deleted at the end of runGhc(T) + ftcCurrentModule :: !(Set FilePath) + -- ^ Files that will be deleted the next time + -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the + -- end of the session. + } + +-- | An empty FilesToClean +emptyFilesToClean :: FilesToClean +emptyFilesToClean = FilesToClean Set.empty Set.empty + + + +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags style = SDC + { sdocStyle = style + , sdocColScheme = colScheme dflags + , sdocLastColour = Col.colReset + , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags) + , sdocLineLength = pprCols dflags + , sdocCanUseUnicode = useUnicode dflags + , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags + , sdocDebugLevel = debugLevel dflags + , sdocPprDebug = dopt Opt_D_ppr_debug dflags + , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags + , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags + , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags + , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags + , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags + , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags + , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags + , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags + , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags + , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags + , sdocSuppressTicks = gopt Opt_SuppressTicks dflags + , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags + , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags + , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags + , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags + , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags + , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags + , sdocSuppressUniques = gopt Opt_SuppressUniques dflags + , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags + , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags + , sdocErrorSpans = gopt Opt_ErrorSpans dflags + , sdocStarIsType = xopt LangExt.StarIsType dflags + , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags + , sdocDynFlags = dflags + } diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot new file mode 100644 index 0000000000..c61d6b5297 --- /dev/null +++ b/compiler/GHC/Driver/Session.hs-boot @@ -0,0 +1,17 @@ +module GHC.Driver.Session where + +import GhcPrelude +import GHC.Platform +import {-# SOURCE #-} Outputable + +data DynFlags +data DumpFlag +data GeneralFlag + +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int +unsafeGlobalDynFlags :: DynFlags +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool +initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs new file mode 100644 index 0000000000..7fd8fe73c3 --- /dev/null +++ b/compiler/GHC/Driver/Types.hs @@ -0,0 +1,3268 @@ +{- +(c) The University of Glasgow, 2006 + +\section[GHC.Driver.Types]{Types for the per-module compiler} +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} + +-- | Types for the per-module compiler +module GHC.Driver.Types ( + -- * compilation state + HscEnv(..), hscEPS, + FinderCache, FindResult(..), InstalledFindResult(..), + Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, + HscStatus(..), + IServ(..), + + -- * ModuleGraph + ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, + mgModSummaries, mgElemModule, mgLookupModule, + needsTemplateHaskellOrQQ, mgBootModules, + + -- * Hsc monad + Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc, + + -- * Information about modules + ModDetails(..), emptyModDetails, + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), + ForeignSrcLang(..), + phaseForeignLanguage, + + ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps, + home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary, + msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), isTemplateHaskellOrQQNonBoot, + + -- * Information about the module being compiled + -- (re-exported from GHC.Driver.Phases) + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + + + -- * State relating to modules in this package + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, + addToHpt, addListToHpt, lookupHptDirectly, listToHpt, + hptCompleteSigs, + hptInstances, hptRules, pprHPT, + + -- * State relating to known packages + ExternalPackageState(..), EpsStats(..), addEpsInStats, + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, + lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule, + + PackageInstEnv, PackageFamInstEnv, PackageRuleBase, + PackageCompleteMatchMap, + + mkSOName, mkHsSOName, soExt, + + -- * Metaprogramming + MetaRequest(..), + MetaResult, -- data constructors not exported to ensure correct response type + metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, + MetaHook, + + -- * Annotations + prepareAnnotations, + + -- * Interactive context + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, + extendInteractiveContext, extendInteractiveContextWithIds, + substInteractiveContext, + setInteractivePrintName, icInteractiveModule, + InteractiveImport(..), setInteractivePackage, + mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, + + -- * Interfaces + ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), + mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, + emptyIfaceWarnCache, mi_boot, mi_fix, + mi_semantic_module, + mi_free_holes, + renameFreeHoles, + + -- * Fixity + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, + + -- * TyThings and type environments + TyThing(..), tyThingAvailInfo, + tyThingTyCon, tyThingDataCon, tyThingConLike, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, + implicitTyThings, implicitTyConThings, implicitClassThings, + isImplicitTyThing, + + TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, + typeEnvFromEntities, mkTypeEnvWithImplicits, + extendTypeEnv, extendTypeEnvList, + extendTypeEnvWithIds, plusTypeEnv, + lookupTypeEnv, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, + typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, + + -- * MonadThings + MonadThings(..), + + -- * Information on imports and exports + WhetherHasOrphans, IsBootInterface, Usage(..), + Dependencies(..), noDependencies, + updNameCache, + IfaceExport, + + -- * Warnings + Warnings(..), WarningTxt(..), plusWarns, + + -- * Linker stuff + Linkable(..), isObjectLinkable, linkableObjs, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + + -- * Program coverage + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- * Breakpoints + ModBreaks (..), emptyModBreaks, + + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + + -- * result of the parser + HsParsedModule(..), + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, throwErrors, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, + + -- * COMPLETE signature + CompleteMatch(..), CompleteMatchMap, + mkCompleteMatchMap, extendCompleteMatchMap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.ByteCode.Types +import GHC.Runtime.Eval.Types ( Resume ) +import GHCi.Message ( Pipe ) +import GHCi.RemoteTypes +import GHC.ForeignSrcLang + +import UniqFM +import GHC.Hs +import RdrName +import Avail +import Module +import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import FamInstEnv +import CoreSyn ( CoreProgram, RuleBase, CoreRule ) +import Name +import NameEnv +import VarSet +import Var +import Id +import IdInfo ( IdDetails(..), RecSelParent(..)) +import Type + +import ApiAnnotation ( ApiAnns ) +import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) +import TysWiredIn +import GHC.Driver.Packages hiding ( Version(..) ) +import GHC.Driver.CmdLine +import GHC.Driver.Session +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Driver.Phases ( Phase, HscSource(..), hscSourceString + , isHsBootOrSig, isHsigFile ) +import qualified GHC.Driver.Phases as Phase +import BasicTypes +import GHC.Iface.Syntax +import Maybes +import Outputable +import SrcLoc +import Unique +import UniqDFM +import FastString +import StringBuffer ( StringBuffer ) +import Fingerprint +import MonadUtils +import Bag +import Binary +import ErrUtils +import NameCache +import GHC.Platform +import Util +import UniqDSet +import GHC.Serialized ( Serialized ) +import qualified GHC.LanguageExtensions as LangExt + +import Foreign +import Control.Monad ( guard, liftM, ap ) +import Data.IORef +import Data.Time +import Exception +import System.FilePath +import Control.Concurrent +import System.Process ( ProcessHandle ) +import Control.DeepSeq +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class + +-- ----------------------------------------------------------------------------- +-- Compilation state +-- ----------------------------------------------------------------------------- + +-- | Status of a compilation to hard-code +data HscStatus + -- | Nothing to do. + = HscNotGeneratingCode ModIface ModDetails + -- | Nothing to do because code already exists. + | HscUpToDate ModIface ModDetails + -- | Update boot file result. + | HscUpdateBoot ModIface ModDetails + -- | Generate signature file (backpack) + | HscUpdateSig ModIface ModDetails + -- | Recompile this module. + | HscRecomp + { hscs_guts :: CgGuts + -- ^ Information for the code generator. + , hscs_mod_location :: !ModLocation + -- ^ Module info + , hscs_mod_details :: !ModDetails + , hscs_partial_iface :: !PartialModIface + -- ^ Partial interface + , hscs_old_iface_hash :: !(Maybe Fingerprint) + -- ^ Old interface hash for this compilation, if an old interface file + -- exists. Pass to `hscMaybeWriteIface` when writing the interface to + -- avoid updating the existing interface when the interface isn't + -- changed. + , hscs_iface_dflags :: !DynFlags + -- ^ Generate final iface using this DynFlags. + -- FIXME (osa): I don't understand why this is necessary, but I spent + -- almost two days trying to figure this out and I couldn't .. perhaps + -- someone who understands this code better will remove this later. + } +-- Should HscStatus contain the HomeModInfo? +-- All places where we return a status we also return a HomeModInfo. + +-- ----------------------------------------------------------------------------- +-- The Hsc monad: Passing an environment and warning state + +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + deriving (Functor) + +instance Applicative Hsc where + pure a = Hsc $ \_ w -> return (a, w) + (<*>) = ap + +instance Monad Hsc where + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +mkInteractiveHscEnv :: HscEnv -> HscEnv +mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags } + where + interactive_dflags = ic_dflags (hsc_IC hsc_env) + +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) + +-- ----------------------------------------------------------------------------- +-- Source Errors + +-- When the compiler (GHC.Driver.Main) discovers errors, it throws an +-- exception in the IO monad. + +mkSrcErr :: ErrorMessages -> SourceError +mkSrcErr = SourceError + +srcErrorMessages :: SourceError -> ErrorMessages +srcErrorMessages (SourceError msgs) = msgs + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + +throwErrors :: MonadIO io => ErrorMessages -> io a +throwErrors = liftIO . throwIO . mkSrcErr + +throwOneError :: MonadIO io => ErrMsg -> io a +throwOneError = throwErrors . unitBag + +-- | A source error is an error that is caused by one or more errors in the +-- source code. A 'SourceError' is thrown by many functions in the +-- compilation pipeline. Inside GHC these errors are merely printed via +-- 'log_action', but API clients may treat them differently, for example, +-- insert them into a list box. If you want the default behaviour, use the +-- idiom: +-- +-- > handleSourceError printExceptionAndWarnings $ do +-- > ... api calls that may fail ... +-- +-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. +-- This list may be empty if the compiler failed due to @-Werror@ +-- ('Opt_WarnIsError'). +-- +-- See 'printExceptionAndWarnings' for more information on what to take care +-- of when writing a custom error handler. +newtype SourceError = SourceError ErrorMessages + +instance Show SourceError where + show (SourceError msgs) = unlines . map show . bagToList $ msgs + +instance Exception SourceError + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleSourceError :: (ExceptionMonad m) => + (SourceError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleSourceError handler act = + gcatch act (\(e :: SourceError) -> handler e) + +-- | An error thrown if the GHC API is used in an incorrect fashion. +newtype GhcApiError = GhcApiError String + +instance Show GhcApiError where + show (GhcApiError msg) = msg + +instance Exception GhcApiError + +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns = do + let (make_error, warns') = + mapAccumBagL + (\make_err warn -> + case isWarnMsgFatal dflags warn of + Nothing -> + (make_err, warn) + Just err_reason -> + (True, warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason + })) + False warns + if make_error + then throwIO (mkSrcErr warns') + else printBagOfErrors dflags warns + +handleFlagWarnings :: DynFlags -> [Warn] -> IO () +handleFlagWarnings dflags warns = do + let warns' = filter (shouldPrintWarning dflags . warnReason) warns + + -- It would be nicer if warns :: [Located MsgDoc], but that + -- has circular import problems. + bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) + | Warn _ (L loc warn) <- warns' ] + + printOrThrowWarnings dflags bag + +-- Given a warn reason, check to see if it's associated -W opt is enabled +shouldPrintWarning :: DynFlags -> GHC.Driver.CmdLine.WarnReason -> Bool +shouldPrintWarning dflags ReasonDeprecatedFlag + = wopt Opt_WarnDeprecatedFlags dflags +shouldPrintWarning dflags ReasonUnrecognisedFlag + = wopt Opt_WarnUnrecognisedWarningFlags dflags +shouldPrintWarning _ _ + = True + +{- +************************************************************************ +* * +\subsection{HscEnv} +* * +************************************************************************ +-} + +-- | HscEnv is like 'Session', except that some of the fields are immutable. +-- An HscEnv is used to compile a single module from plain Haskell source +-- code (after preprocessing) to either C, assembly or C--. It's also used +-- to store the dynamic linker state to allow for multiple linkers in the +-- same address space. +-- Things like the module graph don't change during a single compilation. +-- +-- Historical note: \"hsc\" used to be the name of the compiler binary, +-- when there was a separate driver and compiler. To compile a single +-- module, the driver would invoke hsc on the source code... so nowadays +-- we think of hsc as the layer of the compiler that deals with compiling +-- a single module. +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- ^ The dynamic flag settings + + hsc_targets :: [Target], + -- ^ The targets (or roots) of the current session + + hsc_mod_graph :: ModuleGraph, + -- ^ The module graph of the current session + + hsc_IC :: InteractiveContext, + -- ^ The context for evaluating interactive statements + + hsc_HPT :: HomePackageTable, + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'hsc_HPT' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), + -- ^ Information about the currently loaded external packages. + -- This is mutable because packages will be demand-loaded during + -- a compilation run as required. + + hsc_NC :: {-# UNPACK #-} !(IORef NameCache), + -- ^ As with 'hsc_EPS', this is side-effected by compiling to + -- reflect sucking in interface files. They cache the state of + -- external interface files, in effect. + + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + -- ^ The cached result of performing finding in the file system + + 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 + -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] + + , hsc_iserv :: MVar (Maybe IServ) + -- ^ interactive server process. Created the first + -- time it is needed. + + , hsc_dynLinker :: DynLinker + -- ^ dynamic linker. + + } + +-- Note [hsc_type_env_var hack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- hsc_type_env_var is used to initialize tcg_type_env_var, and +-- eventually it is the mutable variable that is queried from +-- if_rec_types to get a TypeEnv. So, clearly, it's something +-- related to knot-tying (see Note [Tying the knot]). +-- hsc_type_env_var is used in two places: initTcRn (where +-- it initializes tcg_type_env_var) and initIfaceCheck +-- (where it initializes if_rec_types). +-- +-- But why do we need a way to feed a mutable variable in? Why +-- can't we just initialize tcg_type_env_var when we start +-- typechecking? The problem is we need to knot-tie the +-- EPS, and we may start adding things to the EPS before type +-- checking starts. +-- +-- Here is a concrete example. Suppose we are running +-- "ghc -c A.hs", and we have this file system state: +-- +-- A.hs-boot A.hi-boot **up to date** +-- B.hs B.hi **up to date** +-- A.hs A.hi **stale** +-- +-- The first thing we do is run checkOldIface on A.hi. +-- checkOldIface will call loadInterface on B.hi so it can +-- get its hands on the fingerprints, to find out if A.hi +-- needs recompilation. But loadInterface also populates +-- the EPS! And so if compilation turns out to be necessary, +-- as it is in this case, the thunks we put into the EPS for +-- B.hi need to have the correct if_rec_types mutable variable +-- to query. +-- +-- If the mutable variable is only allocated WHEN we start +-- typechecking, then that's too late: we can't get the +-- information to the thunks. So we need to pre-commit +-- to a type variable in 'hscIncrementalCompile' BEFORE we +-- check the old interface. +-- +-- This is all a massive hack because arguably checkOldIface +-- should not populate the EPS. But that's a refactor for +-- another day. + + +data IServ = IServ + { iservPipe :: Pipe + , iservProcess :: ProcessHandle + , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) + , iservPendingFrees :: [HValueRef] + } + +-- | Retrieve the ExternalPackageState cache. +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +data Target + = Target { + targetId :: TargetId, -- ^ module or filename + targetAllowObjCode :: Bool, -- ^ object code allowed? + targetContents :: Maybe (InputFileBuffer, UTCTime) + -- ^ Optional in-memory buffer containing the source code GHC should + -- use for this target instead of reading it from disk. + -- + -- Since GHC version 8.10 modules which require preprocessors such as + -- Literate Haskell or CPP to run are also supported. + -- + -- If a corresponding source file does not exist on disk this will + -- result in a 'SourceError' exception if @targetId = TargetModule _@ + -- is used. However together with @targetId = TargetFile _@ GHC will + -- not complain about the file missing. + } + +data TargetId + = TargetModule ModuleName + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +type InputFileBuffer = StringBuffer + +pprTarget :: Target -> SDoc +pprTarget (Target id obj _) = + (if obj then char '*' else empty) <> pprTargetId id + +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +instance Outputable TargetId where + ppr = pprTargetId + +{- +************************************************************************ +* * +\subsection{Package and Module Tables} +* * +************************************************************************ +-} + +-- | Helps us find information about modules in the home package +type HomePackageTable = DModuleNameEnv HomeModInfo + -- Domain = modules in the home package that have been fully compiled + -- "home" unit id cached here for convenience + +-- | Helps us find information about modules in the imported packages +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +-- | Constructs an empty HomePackageTable +emptyHomePackageTable :: HomePackageTable +emptyHomePackageTable = emptyUDFM + +-- | Constructs an empty PackageIfaceTable +emptyPackageIfaceTable :: PackageIfaceTable +emptyPackageIfaceTable = emptyModuleEnv + +pprHPT :: HomePackageTable -> SDoc +-- A bit arbitrary for now +pprHPT hpt = pprUDFM hpt $ \hms -> + vcat [ hang (ppr (mi_module (hm_iface hm))) + 2 (ppr (md_types (hm_details hm))) + | hm <- hms ] + +lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo +lookupHpt = lookupUDFM + +lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo +lookupHptDirectly = lookupUDFM_Directly + +eltsHpt :: HomePackageTable -> [HomeModInfo] +eltsHpt = eltsUDFM + +filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable +filterHpt = filterUDFM + +allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +allHpt = allUDFM + +mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable +mapHpt = mapUDFM + +delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable +delFromHpt = delFromUDFM + +addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable +addToHpt = addToUDFM + +addListToHpt + :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable +addListToHpt = addListToUDFM + +listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable +listToHpt = listToUDFM + +lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo +-- The HPT is indexed by ModuleName, not Module, +-- we must check for a hit on the right Module +lookupHptByModule hpt mod + = case lookupHpt hpt (moduleName mod) of + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-- | Information about modules in the package being compiled +data HomeModInfo + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + hm_details :: !ModDetails, + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + hm_linkable :: !(Maybe Linkable) + -- ^ The actual artifact we would like to link to access things in + -- this module. + -- + -- 'hm_linkable' might be Nothing: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields + -- in the 'HomePackageTable' will be @Just@. + -- + -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } + +-- | Find the 'ModIface' for a 'Module', searching in both the loaded home +-- and external package module information +lookupIfaceByModule + :: HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule hpt pit mod + = case lookupHptByModule hpt mod of + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod + +-- If the module does come from the home package, why do we look in the PIT as well? +-- (a) In OneShot mode, even home-package modules accumulate in the PIT +-- (b) Even in Batch (--make) mode, there is *one* case where a home-package +-- module is in the PIT, namely GHC.Prim when compiling the base package. +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package +-- of its own, but it doesn't seem worth the bother. + +hptCompleteSigs :: HscEnv -> [CompleteMatch] +hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) +hptInstances hsc_env want_this_module + = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do + guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + in (concat insts, concat famInsts) + +-- | Get rules from modules "below" this one (in the dependency sense) +hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] +hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + + +-- | Get annotations from modules "below" this one (in the dependency sense) +hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + +hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] +hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) + +-- | Get things from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] +hptSomeThingsBelowUs extract include_hi_boot hsc_env deps + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] + + | otherwise + = let hpt = hsc_HPT hsc_env + in + [ thing + | -- Find each non-hi-boot module below me + (mod, is_boot_mod) <- deps + , include_hi_boot || not is_boot_mod + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus filter: + , mod /= moduleName gHC_PRIM + + -- Look it up in the HPT + , let things = case lookupHpt hpt mod of + Just info -> extract info + Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] + msg = vcat [text "missing module" <+> ppr mod, + text "Probable cause: out-of-date interface files"] + -- This really shouldn't happen, but see #962 + + -- And get its dfuns + , thing <- things ] + + +{- +************************************************************************ +* * +\subsection{Metaprogramming} +* * +************************************************************************ +-} + +-- | The supported metaprogramming result types +data MetaRequest + = MetaE (LHsExpr GhcPs -> MetaResult) + | MetaP (LPat GhcPs -> MetaResult) + | MetaT (LHsType GhcPs -> MetaResult) + | MetaD ([LHsDecl GhcPs] -> MetaResult) + | MetaAW (Serialized -> MetaResult) + +-- | data constructors not exported to ensure correct result type +data MetaResult + = MetaResE { unMetaResE :: LHsExpr GhcPs } + | MetaResP { unMetaResP :: LPat GhcPs } + | MetaResT { unMetaResT :: LHsType GhcPs } + | MetaResD { unMetaResD :: [LHsDecl GhcPs] } + | MetaResAW { unMetaResAW :: Serialized } + +type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult + +metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) +metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) + +metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) +metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) + +metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) +metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) + +metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] +metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) + +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized +metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) + +{- +************************************************************************ +* * +\subsection{Dealing with Annotations} +* * +************************************************************************ +-} + +-- | Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +prepareAnnotations hsc_env mb_guts = do + eps <- hscEPS hsc_env + let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + return ann_env + +{- +************************************************************************ +* * +\subsection{The Finder cache} +* * +************************************************************************ +-} + +-- | The 'FinderCache' maps modules to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +type FinderCache = InstalledModuleEnv InstalledFindResult + +data InstalledFindResult + = InstalledFound ModLocation InstalledModule + | InstalledNoPackage InstalledUnitId + | InstalledNotFound [FilePath] (Maybe InstalledUnitId) + +-- | The result of searching for an imported module. +-- +-- NB: FindResult manages both user source-import lookups +-- (which can result in 'Module') as well as direct imports +-- for interfaces (which always result in 'InstalledModule'). +data FindResult + = Found ModLocation Module + -- ^ The module was found + | NoPackage UnitId + -- ^ The requested package was not found + | FoundMultiple [(Module, ModuleOrigin)] + -- ^ _Error_: both in multiple packages + + -- | Not found + | NotFound + { fr_paths :: [FilePath] -- Places where I looked + + , fr_pkg :: Maybe UnitId -- Just p => module is in this package's + -- manifest, but couldn't find + -- the .hi file + + , fr_mods_hidden :: [UnitId] -- Module is in these packages, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, + -- but the *package* is hidden + + -- Modules are in these packages, but it is unusable + , fr_unusables :: [(UnitId, UnusablePackageReason)] + + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules + } + +{- +************************************************************************ +* * +\subsection{Symbol tables and Module details} +* * +************************************************************************ +-} + +{- Note [Interface file stages] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Interface files have two possible stages. + +* A partial stage built from the result of the core pipeline. +* A fully instantiated form. Which also includes fingerprints and + potentially information provided by backends. + +We can build a full interface file two ways: +* Directly from a partial one: + Then we omit backend information and mostly compute fingerprints. +* From a partial one + information produced by a backend. + Then we store the provided information and fingerprint both. +-} + +type PartialModIface = ModIface_ 'ModIfaceCore +type ModIface = ModIface_ 'ModIfaceFinal + +-- | Extends a PartialModIface with information which is either: +-- * Computed after codegen +-- * Or computed just before writing the iface to disk. (Hashes) +-- In order to fully instantiate it. +data ModIfaceBackend = ModIfaceBackend + { mi_iface_hash :: !Fingerprint + -- ^ Hash of the whole interface + , mi_mod_hash :: !Fingerprint + -- ^ Hash of the ABI only + , mi_flag_hash :: !Fingerprint + -- ^ Hash of the important flags used when compiling the module, excluding + -- optimisation flags + , mi_opt_hash :: !Fingerprint + -- ^ Hash of optimisation flags + , mi_hpc_hash :: !Fingerprint + -- ^ Hash of hpc flags + , mi_plugin_hash :: !Fingerprint + -- ^ Hash of plugins + , mi_orphan :: !WhetherHasOrphans + -- ^ Whether this module has orphans + , mi_finsts :: !WhetherHasFamInst + -- ^ Whether this module has family instances. See Note [The type family + -- instance consistency story]. + , mi_exp_hash :: !Fingerprint + -- ^ Hash of export list + , mi_orphan_hash :: !Fingerprint + -- ^ Hash for orphan rules, class and family instances combined + + -- Cached environments for easy lookup. These are computed (lazily) from + -- other fields and are not put into the interface file. + -- Not really produced by the backend but there is no need to create them + -- any earlier. + , mi_warn_fn :: !(OccName -> Maybe WarningTxt) + -- ^ Cached lookup for 'mi_warns' + , mi_fix_fn :: !(OccName -> Maybe Fixity) + -- ^ Cached lookup for 'mi_fixities' + , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) + -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that + -- the thing 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. + } + +data ModIfacePhase + = ModIfaceCore + -- ^ Partial interface built based on output of core pipeline. + | ModIfaceFinal + +-- | Selects a IfaceDecl representation. +-- For fully instantiated interfaces we also maintain +-- a fingerprint, which is used for recompilation checks. +type family IfaceDeclExts (phase :: ModIfacePhase) where + IfaceDeclExts 'ModIfaceCore = IfaceDecl + IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) + +type family IfaceBackendExts (phase :: ModIfacePhase) where + IfaceBackendExts 'ModIfaceCore = () + IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend + + + +-- | A 'ModIface' plus a 'ModDetails' summarises everything we know +-- about a compiled module. The 'ModIface' is the stuff *before* linking, +-- and can be written out to an interface file. The 'ModDetails is after +-- linking and can be completely recovered from just the 'ModIface'. +-- +-- When we read an interface file, we also construct a 'ModIface' from it, +-- except that we explicitly make the 'mi_decls' and a few other fields empty; +-- as when reading we consolidate the declarations etc. into a number of indexed +-- maps and environments in the 'ExternalPackageState'. +data ModIface_ (phase :: ModIfacePhase) + = ModIface { + mi_module :: !Module, -- ^ Name of the module we are for + mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? + + mi_hsc_src :: !HscSource, -- ^ Boot? Signature? + + mi_deps :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + + mi_usages :: [Usage], + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + mi_exports :: ![IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + + mi_used_th :: !Bool, + -- ^ Module required TH splices when it was compiled. + -- This disables recompilation avoidance (see #481). + + mi_fixities :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns :: Warnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls :: [IfaceDeclExts phase], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + mi_globals :: !(Maybe GlobalRdrEnv), + -- ^ Binds all the things defined at the top level in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + -- + -- (We need the source file to figure out the + -- top-level environment, if we didn't compile this module + -- from source then this field contains @Nothing@). + -- + -- Strictly speaking this field should live in the + -- 'HomeModInfo', but that leads to more plumbing. + + -- Instance declarations and rules + mi_insts :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules :: [IfaceRule], -- ^ Sorted rules + + 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. + + mi_trust_pkg :: !Bool, + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [Trust Own Package] in GHC.Rename.Names + mi_complete_sigs :: [IfaceCompleteMatch], + + mi_doc_hdr :: Maybe HsDocString, + -- ^ Module header. + + mi_decl_docs :: DeclDocMap, + -- ^ Docs on declarations. + + mi_arg_docs :: ArgDocMap, + -- ^ Docs on arguments. + + mi_final_exts :: !(IfaceBackendExts phase) + -- ^ Either `()` or `ModIfaceBackend` for + -- a fully instantiated interface. + } + +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> Bool +mi_boot iface = mi_hsc_src iface == HsBootFile + +-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be +-- found, 'defaultFixity' is returned instead. +mi_fix :: ModIface -> OccName -> Fixity +mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity + +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module' +-- will be @<A>@. +mi_semantic_module :: ModIface_ a -> Module +mi_semantic_module iface = case mi_sig_of iface of + Nothing -> mi_module iface + Just mod -> mod + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case splitModuleInsts (mi_module iface) of + (_, Just indef) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) + _ -> emptyUniqDSet + where + cands = map fst (dep_mods (mi_deps iface)) + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = ModIfaceBackend { + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash + }}) = do + put_ bh mod + put_ bh sig_of + put_ bh hsc_src + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh opt_hash + put_ bh hpc_hash + put_ bh plugin_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + put_ bh complete_sigs + lazyPut bh doc_hdr + lazyPut bh decl_docs + lazyPut bh arg_docs + + get bh = do + mod <- get bh + sig_of <- get bh + hsc_src <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + opt_hash <- get bh + hpc_hash <- get bh + plugin_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + complete_sigs <- get bh + doc_hdr <- lazyGet bh + decl_docs <- lazyGet bh + arg_docs <- lazyGet bh + return (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = ModIfaceBackend { + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash, + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls + }}) + +-- | The original names declared of a certain module that are exported +type IfaceExport = AvailInfo + +emptyPartialModIface :: Module -> PartialModIface +emptyPartialModIface mod + = ModIface { mi_module = mod, + mi_sig_of = Nothing, + mi_hsc_src = HsSrcFile, + mi_deps = noDependencies, + mi_usages = [], + mi_exports = [], + mi_used_th = False, + mi_fixities = [], + mi_warns = NoWarnings, + mi_anns = [], + mi_insts = [], + mi_fam_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, + mi_hpc = False, + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False, + mi_complete_sigs = [], + mi_doc_hdr = Nothing, + mi_decl_docs = emptyDeclDocMap, + mi_arg_docs = emptyArgDocMap, + mi_final_exts = () } + +emptyFullModIface :: Module -> ModIface +emptyFullModIface mod = + (emptyPartialModIface mod) + { mi_decls = [] + , mi_final_exts = ModIfaceBackend + { mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, + mi_flag_hash = fingerprint0, + mi_opt_hash = fingerprint0, + mi_hpc_hash = fingerprint0, + mi_plugin_hash = fingerprint0, + mi_orphan = False, + mi_finsts = False, + mi_exp_hash = fingerprint0, + mi_orphan_hash = fingerprint0, + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache } } + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl' add_decl emptyOccEnv pairs + add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + where + add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + +-- | The 'ModDetails' is essentially a cache for information in the 'ModIface' +-- for home modules only. Information relating to packages will be loaded into +-- global environments in 'ExternalPackageState'. +data ModDetails + = ModDetails { + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, -- ^ Local type environment for this particular module + -- Includes Ids, TyCons, PatSyns + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + md_fam_insts :: ![FamInst], + md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules + md_anns :: ![Annotation], -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module + md_complete_sigs :: [CompleteMatch] + -- ^ Complete match pragmas for this module + } + +-- | Constructs an empty ModDetails +emptyModDetails :: ModDetails +emptyModDetails + = ModDetails { md_types = emptyTypeEnv, + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [], + md_anns = [], + md_complete_sigs = [] } + +-- | Records the modules directly imported by a module for extracting e.g. +-- usage information, and also to give better error message +type ImportedMods = ModuleEnv [ImportedBy] + +-- | If a module was "imported" by the user, we associate it with +-- more detailed usage information 'ImportedModsVal'; a module +-- imported by the system only gets used for usage information. +data ImportedBy + = ImportedByUser ImportedModsVal + | ImportedBySystem + +importedByUser :: [ImportedBy] -> [ImportedModsVal] +importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys +importedByUser (ImportedBySystem : bys) = importedByUser bys +importedByUser [] = [] + +data ImportedModsVal + = ImportedModsVal { + imv_name :: ModuleName, -- ^ The name the module is imported with + imv_span :: SrcSpan, -- ^ the source span of the whole import + imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import + imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import + imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide + -- NB. BangPattern here: otherwise this leaks. (#15111) + imv_qualified :: Bool -- ^ whether this is a qualified import + } + +-- | A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a 'ModIface' and +-- 'ModDetails' are extracted and the ModGuts is discarded. +data ModGuts + = ModGuts { + mg_module :: !Module, -- ^ Module being compiled + mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module + mg_loc :: SrcSpan, -- ^ For error messages from inner passes + mg_exports :: ![AvailInfo], -- ^ What it exports + mg_deps :: !Dependencies, -- ^ What it depends on, directly or + -- otherwise + mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. + + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + -- (includes TyCons for classes) + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module + mg_fam_insts :: ![FamInst], + -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module + mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains + -- See Note [Overall plumbing for rules] in Rules.hs + mg_binds :: !CoreProgram, -- ^ Bindings for this module + mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module + mg_foreign_files :: ![(ForeignSrcLang, FilePath)], + -- ^ Files to be compiled with the C compiler + mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, -- ^ Class instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment 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 [Trust Own Package] + -- in GHC.Rename.Names + + mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. + mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. + mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. + } + +-- The ModGuts takes on several slightly different forms: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) + +-- | A restricted form of 'ModGuts' for code generation purposes +data CgGuts + = CgGuts { + cg_module :: !Module, + -- ^ Module being compiled + + cg_tycons :: [TyCon], + -- ^ Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables. Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: CoreProgram, + -- ^ The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data constructor wrappers. But *not* + -- data constructor workers; reason: we regard them + -- as part of the code-gen of tycons + + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign_files :: ![(ForeignSrcLang, FilePath)], + cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to + -- generate #includes for C code gen + cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information + cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints + cg_spt_entries :: [SptEntry] + -- ^ Static pointer table entries for static forms defined in + -- the module. + -- See Note [Grand plan for static forms] in StaticPtrTable + } + +----------------------------------- +-- | Foreign export stubs +data ForeignStubs + = NoStubs + -- ^ We don't have any stubs + | ForeignStubs SDoc SDoc + -- ^ There are some stubs. Parameters: + -- + -- 1) Header file prototypes for + -- "foreign exported" functions + -- + -- 2) C stubs to use when calling + -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) + +{- +************************************************************************ +* * + The interactive context +* * +************************************************************************ + +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactiveUnitId, and +PrelNames.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at <interactive>:2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined. + +So the main invariant continues to hold, that in any session an +original name M.T only refers to one unique thing. (In a previous +iteration both the T's above were called :Interactive.T, albeit with +different uniques, which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when we + extend the HPT. + + * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -this-unit-id says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get to + be in the 'interactive' package? Simply by setting the tcg_mod + field of the TcGblEnv to "interactive:Ghci1". This is done by the + call to initTc in initTcInteractive, which in turn get the module + from it 'icInteractiveModule' field of the interactive context. + + The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. + + * The main trickiness is that the type environment (tcg_type_env) and + fixity envt (tcg_fix_env), now contain entities from all the + interactive-package modules (Ghci1, Ghci2, ...) together, rather + than just a single module as is usually the case. So you can't use + "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs + the HPT/PTE. This is a change, but not a problem provided you + know. + +* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields + of the TcGblEnv, which collect "things defined in this module", all + refer to stuff define in a single GHCi command, *not* all the commands + so far. + + In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from + all GhciN modules, which makes sense -- they are all "home package" + modules. + + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds, with + b) An External Name, like Ghci4.foo + See Note [The interactive package] above + c) A tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) Having an External Name is important because of Note + [GlobalRdrEnv shadowing] in RdrName + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +Where do interactively-bound Ids come from? + + - GHCi REPL Stmts e.g. + ghci> let foo x = x+1 + These start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. Then in tcRnStmt they are externalised via + TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo. + + - Ids bound by the debugger etc have Names constructed by + GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by + mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are + all Global, External. + + - TyCons, Classes, and Ids bound by other top-level declarations in + GHCi (eg foreign import, record selectors) also get External + Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + +Note [Override identical instances in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you declare a new instance in GHCi that is identical to a previous one, +we simply override the previous one; we don't regard it as overlapping. +e.g. Prelude> data T = A | B + Prelude> instance Eq T where ... + Prelude> instance Eq T where ... -- This one overrides + +It's exactly the same for type-family instances. See #7102 +-} + +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHCi session. +data InteractiveContext + = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interactive expressions + -- and statements. + + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] + + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with + -- these imports + -- + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front) + -- See Note [ic_tythings] + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The cached 'GlobalRdrEnv', built by + -- 'GHC.Runtime.Eval.setContext' and updated regularly + -- It contains everything in scope at the command line, + -- including everything in ic_tythings + + ic_instances :: ([ClsInst], [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. + + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_default :: Maybe [Type], + -- ^ The current default types, set by a 'default' declaration + + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath + -- virtual CWD of the program + } + +data InteractiveImport + = IIDecl (ImportDecl GhcPs) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule ModuleName + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + + +-- | Constructs an empty InteractiveContext. +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = Nothing, + ic_resume = [], + ic_cwd = Nothing } + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule index + +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings) +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs = ic_tythings + +-- | Get the PrintUnqualified function based on the flags and this InteractiveContext +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified dflags grenv + +-- | extendInteractiveContext is called with new TyThings recently defined to update the +-- InteractiveContext to include them. Ids are easily removed when shadowed, +-- but Classes and TyCons are not. Some work could be done to determine +-- whether they are entirely shadowed, but as you could still have references +-- to them (e.g. instances for classes or values of the type for TyCons), it's +-- not clear whether removing them is even the appropriate behavior. +extendInteractiveContext :: InteractiveContext + -> [TyThing] + -> [ClsInst] -> [FamInst] + -> Maybe [Type] + -> FixityEnv + -> InteractiveContext +extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + -- Always bump this; even instances should create + -- a new mod_index (#9426) + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings + , ic_instances = ( new_cls_insts ++ old_cls_insts + , new_fam_insts ++ fam_insts ) + -- we don't shadow old family instances (#7102), + -- so don't need to remove them here + , ic_default = defaults + , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] + } + where + new_ids = [id | AnId id <- new_tythings] + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + + -- Discard old instances that have been fully overridden + -- See Note [Override identical instances in GHCi] + (cls_insts, fam_insts) = ic_instances ictxt + old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts + +extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext +-- Just a specialised version +extendInteractiveContextWithIds ictxt new_ids + | null new_ids = ictxt + | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } + where + new_tythings = map AnId new_ids + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + +shadowed_by :: [Id] -> TyThing -> Bool +shadowed_by ids = shadowed + where + shadowed id = getOccName id `elemOccSet` new_occs + new_occs = mkOccSet (map getOccName ids) + +setInteractivePackage :: HscEnv -> HscEnv +-- Set the 'thisPackage' DynFlag to 'interactive' +setInteractivePackage hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } + +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + + -- ToDo: should not add Ids to the gbl env here + +-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the GlobalRdrEnv. +icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv env tythings + = foldr add env tythings -- Foldr makes things in the front of + -- the list shadow things at the back + where + -- One at a time, to ensure each shadows the previous ones + add thing env + | is_sub_bndr thing + = env + | otherwise + = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + where + env1 = shadowNames env (concatMap availNames avail) + avail = tyThingAvailInfo thing + + -- Ugh! The new_tythings may include record selectors, since they + -- are not implicit-ids, and must appear in the TypeEnv. But they + -- will also be brought into scope by the corresponding (ATyCon + -- tc). And we want the latter, because that has the correct + -- parent (#10520) + is_sub_bndr (AnId f) = case idDetails f of + RecSelId {} -> True + ClassOpId {} -> True + _ -> False + is_sub_bndr _ = False + +substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst + | isEmptyTCvSubst subst = ictxt + | otherwise = ictxt { ic_tythings = map subst_ty tts } + where + subst_ty (AnId id) + = AnId $ id `setIdType` substTyAddInScope subst (idType id) + -- Variables in the interactive context *can* mention free type variables + -- because of the runtime debugger. Otherwise you'd expect all + -- variables bound in the interactive context to be closed. + subst_ty tt + = tt + +instance Outputable InteractiveImport where + ppr (IIModule m) = char '*' <> ppr m + ppr (IIDecl d) = ppr d + +{- +************************************************************************ +* * + Building a PrintUnqualified +* * +************************************************************************ + +Note [Printing original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" NameUnqual + 2. There is an X for which X.T + uniquely maps to P:M.T ---> "X.T" NameQual X + 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 + 4. Otherwise ---> "P:M.T" NameNotInScope2 + +(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at +all. In these cases we still want to refer to the name as "M.T", *but* +"M.T" might mean something else in the current scope (e.g. if there's +an "import X as M"), so to avoid confusion we avoid using "M.T" if +there's already a binding for it. Instead we write P:M.T. + +There's one further subtlety: in case (3), what if there are two +things around, P1:M.T and P2:M.T? Then we don't want to print both of +them as M.T! However only one of the modules P1:M and P2:M can be +exposed (say P2), so we use M.T for that, and P1:M.T for the other one. +This is handled by the qual_mod component of PrintUnqualified, inside +the (ppr mod) of case (3), in Name.pprModulePrefix + +Note [Printing unit ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +UnitId, the situation can be different: if the key is instantiated with +some holes, we should try to give the user some more useful information. +-} + +-- | Creates some functions that work out the best ways to format +-- names for the user according to a set of heuristics. +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage dflags) + where + qual_name mod occ + | [gre] <- unqual_gres + , right_name gre + = NameUnqual -- If there's a unique entity that's in scope + -- unqualified with 'occ' AND that entity is + -- the right one, then we can use the unqualified name + + | [] <- unqual_gres + , any is_name forceUnqualNames + , not (isDerivedOccName occ) + = NameUnqual -- Don't qualify names that come from modules + -- that come with GHC, often appear in error messages, + -- but aren't typically in scope. Doing this does not + -- cause ambiguity, and it reduces the amount of + -- qualification in error messages thus improving + -- readability. + -- + -- A motivating example is 'Constraint'. It's often not + -- in scope, but printing GHC.Prim.Constraint seems + -- overkill. + + | [gre] <- qual_gres + = NameQual (greQualModName gre) + + | null qual_gres + = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 + + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + is_name :: Name -> Bool + is_name name = ASSERT2( isExternalName name, ppr name ) + nameModule name == mod && nameOccName name == occ + + forceUnqualNames :: [Name] + forceUnqualNames = + map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] + ++ [ eqTyConName ] + + right_name gre = nameModule_maybe (gre_name gre) == Just mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | moduleUnitId mod == thisPackage dflags = False + + | [(_, pkgconfig)] <- lookup, + packageConfigId pkgconfig == moduleUnitId mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a unit id if the package ID would be ambiguous. +mkQualPackage :: DynFlags -> QueryQualifyPackage +mkQualPackage dflags uid + | uid == mainUnitId || uid == interactiveUnitId + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | Just pkgid <- mb_pkgid + , searchPackageId dflags pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where mb_pkgid = fmap sourcePackageId (lookupUnit dflags uid) + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + +{- +************************************************************************ +* * + Implicit TyThings +* * +************************************************************************ + +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implicit. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). +-} + +-- | Determine the 'TyThing's brought into scope by another 'TyThing' +-- /other/ than itself. For example, Id's don't have any implicit TyThings +-- as they just bring themselves into scope, but classes bring their +-- dictionary datatype, type constructor and some selector functions into +-- scope, just for a start! + +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by GHC.Iface.Load.ifaceDeclImplicitBndrs, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in GHC.Iface.Load.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = dataConImplicitTyThings dc + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface file + -- Unless a record pat syn when there are implicit selectors + -- They are still not included here as `implicitConLikeThings` is + -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked + -- by `tcTopValBinds`. + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + + -- associated types + -- No recursive call for the classATs, because they + -- are only the family decls; they have no implicit things + map ATyCon (classATs cl) ++ + + -- superclass and operation selectors + map AnId (classAllSelIds cl) + +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = class_stuff ++ + -- fields (names of selectors) + + -- (possibly) implicit newtype axioms + -- or type family axioms + implicitCoTyCon tc ++ + + -- for each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + [ thing | dc <- tyConDataCons tc + , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl + +-- For newtypes and closed type families (only) add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc + = [ACoAxiom co] + | otherwise = [] + +-- | Returns @True@ if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon {} -> True + PatSynCon {} -> False +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax + +-- | tyThingParent_maybe x returns (Just p) +-- when pprTyThingInContext should print a declaration for p +-- (albeit with some "..." in it) when asked to show x +-- It returns the *immediate* parent. So a datacon returns its tycon +-- but the tycon could be the associated type of a class, so it in turn +-- might have a parent. +tyThingParent_maybe :: TyThing -> Maybe TyThing +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing +tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of + Just tc -> Just (ATyCon tc) + Nothing -> Nothing +tyThingParent_maybe (AnId id) = case idDetails id of + RecSelId { sel_tycon = RecSelData tc } -> + Just (ATyCon tc) + ClassOpId cls -> + Just (ATyCon (classTyCon cls)) + _other -> Nothing +tyThingParent_maybe _other = Nothing + +tyThingsTyCoVars :: [TyThing] -> TyCoVarSet +tyThingsTyCoVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyCoVarsOfType $ idType id + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyCoVarsOfType $ tyConKind tc + ttToVarSet (ACoAxiom _) = emptyVarSet + +-- | The Names that a TyThing should bring into scope. Used to build +-- the GlobalRdrEnv for the InteractiveContext. +tyThingAvailInfo :: TyThing -> [AvailInfo] +tyThingAvailInfo (ATyCon t) + = case tyConClass_maybe t of + Just c -> [AvailTC n (n : map getName (classMethods c) + ++ map getName (classATs c)) + [] ] + where n = getName c + Nothing -> [AvailTC n (n : map getName dcs) flds] + where n = getName t + dcs = tyConDataCons t + flds = tyConFieldLabels t +tyThingAvailInfo (AConLike (PatSynCon p)) + = map avail ((getName p) : map flSelector (patSynFieldLabels p)) +tyThingAvailInfo t + = [avail (getName t)] + +{- +************************************************************************ +* * + TypeEnv +* * +************************************************************************ +-} + +-- | A map from 'Name's to 'TyThing's, constructed by typechecking +-- local declarations or interface files +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] +typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] +typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs famInsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ) + where + all_tcs = tcs ++ famInstsRepTyCons famInsts + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl' extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + +plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv +plusTypeEnv env1 env2 = plusNameEnv env1 env2 + +-- | Find the 'TyThing' for the given 'Name' by using all the resources +-- at our disposal: the compiled modules in the 'HomePackageTable' and the +-- compiled modules in other packages that live in 'PackageTypeEnv'. Note +-- that this does NOT look up the 'TyThing' in the module being compiled: you +-- have to do that yourself, if desired +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT + = lookupNameEnv pte name + | otherwise + = case lookupHptByModule hpt mod of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name + where + mod = ASSERT2( isExternalName name, ppr name ) + if isHoleName name + then mkModule (thisPackage dflags) (moduleName (nameModule name)) + else nameModule name + +-- | As 'lookupType', but with a marginally easier-to-use interface +-- if you have a 'HscEnv' +lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) +lookupTypeHscEnv hsc_env name = do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType dflags hpt (eps_PTE eps) name + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + +-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise +tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) + +-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise +tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. +-- Panics otherwise +tyThingConLike :: HasDebugCallStack => TyThing -> ConLike +tyThingConLike (AConLike dc) = dc +tyThingConLike other = pprPanic "tyThingConLike" (ppr other) + +-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise +tyThingId :: HasDebugCallStack => TyThing -> Id +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (ppr other) + +{- +************************************************************************ +* * +\subsection{MonadThings and friends} +* * +************************************************************************ +-} + +-- | Class that abstracts out the common ability of the monads in GHC +-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides +-- a number of related convenience functions for accessing particular +-- kinds of 'TyThing' +class Monad m => MonadThings m where + lookupThing :: Name -> m TyThing + + lookupId :: Name -> m Id + lookupId = liftM tyThingId . lookupThing + + lookupDataCon :: Name -> m DataCon + lookupDataCon = liftM tyThingDataCon . lookupThing + + lookupTyCon :: Name -> m TyCon + lookupTyCon = liftM tyThingTyCon . lookupThing + +-- Instance used in GHC.HsToCore.Quote +instance MonadThings m => MonadThings (ReaderT s m) where + lookupThing = lift . lookupThing + +{- +************************************************************************ +* * +\subsection{Auxiliary types} +* * +************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere +-} + +------------------ Warnings ------------------------- +-- | Warning information for a module +data Warnings + = NoWarnings -- ^ Nothing deprecated + | WarnAll WarningTxt -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. + deriving( Eq ) + +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + +-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' +mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt +mkIfaceWarnCache NoWarnings = \_ -> Nothing +mkIfaceWarnCache (WarnAll t) = \_ -> Just t +mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) + +emptyIfaceWarnCache :: OccName -> Maybe WarningTxt +emptyIfaceWarnCache _ = Nothing + +plusWarns :: Warnings -> Warnings -> Warnings +plusWarns d NoWarnings = d +plusWarns NoWarnings d = d +plusWarns _ (WarnAll t) = WarnAll t +plusWarns (WarnAll t) _ = WarnAll t +plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) + +-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Maybe Fixity +emptyIfaceFixCache _ = Nothing + +-- | Fixity environment mapping names to their fixities +type FixityEnv = NameEnv FixItem + +-- | Fixity information for an 'Name'. We keep the OccName in the range +-- so that we can generate an interface from it +data FixItem = FixItem OccName Fixity + +instance Outputable FixItem where + ppr (FixItem occ fix) = ppr fix <+> ppr occ + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity + +{- +************************************************************************ +* * +\subsection{WhatsImported} +* * +************************************************************************ +-} + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A transformation rule in a module other than the one defining +-- the function in the head of the rule +-- +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- | Did this module originate from a *-boot file? +type IsBootInterface = Bool + +-- | Dependency information about ALL modules and packages below this one +-- in the import hierarchy. +-- +-- Invariant: the dependencies of a module @M@ never includes @M@. +-- +-- Invariant: none of the lists contain duplicates. +data Dependencies + = Deps { dep_mods :: [(ModuleName, IsBootInterface)] + -- ^ All home-package modules transitively below this one + -- I.e. modules that this one imports, or that are in the + -- dep_mods of those directly-imported modules + + , dep_pkgs :: [(InstalledUnitId, Bool)] + -- ^ All packages transitively below this module + -- I.e. packages to which this module's direct imports belong, + -- or that are in the dep_pkgs of those modules + -- The bool indicates if the package is required to be + -- trusted when the module is imported as a safe import + -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names + + , dep_orphs :: [Module] + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) + -- This does NOT include us, unlike 'imp_orphs'. + + , dep_finsts :: [Module] + -- ^ Transitive closure of depended upon modules which + -- contain family instances (whether home or external). + -- This is used by 'checkFamInstConsistency'. This + -- does NOT include us, unlike 'imp_finsts'. See Note + -- [The type family instance consistency story]. + + , dep_plgins :: [ModuleName] + -- ^ All the plugins used while compiling this module. + } + deriving( Eq ) + -- Equality used only for old/new comparison in GHC.Iface.Utils.addFingerprints + -- See 'TcRnTypes.ImportAvails' for details on dependencies. + +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + put_ bh (dep_plgins deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + pl <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis, dep_plgins = pl }) + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] [] [] + +-- | Records modules for which changes may force recompilation of this module +-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- This differs from Dependencies. A module X may be in the dep_mods of this +-- module (via an import chain) but if we don't use anything from X it won't +-- appear in our Usage +data Usage + -- | Module from another package + = UsagePackageModule { + usg_mod :: Module, + -- ^ External package module depended on + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | Module from the current package + | UsageHomeModule { + usg_mod_name :: ModuleName, + -- ^ Name of the module + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_entities :: [(OccName,Fingerprint)], + -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. + -- NB: usages are for parent names only, e.g. type constructors + -- but not the associated data constructors. + usg_exports :: Maybe Fingerprint, + -- ^ Fingerprint for the export list of this module, + -- if we directly imported it (and hence we depend on its export list) + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } -- ^ Module from the current package + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' + | UsageFile { + usg_file_path :: FilePath, + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint + -- ^ 'Fingerprint' of the file contents. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 + } + -- | A requirement which was merged into this one. + | UsageMergedRequirement { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } + deriving( Eq ) + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported + -- everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash + -- in the importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_file_hash usg) + + put_ bh usg@UsageMergedRequirement{} = do + putByte bh 3 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + hash <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash } + 3 -> do + mod <- get bh + hash <- get bh + return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } + i -> error ("Binary.get(Usage): " ++ show i) + +{- +************************************************************************ +* * + The External Package State +* * +************************************************************************ +-} + +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv +type PackageAnnEnv = AnnEnv +type PackageCompleteMatchMap = CompleteMatchMap + +-- | Information about other packages that we have slurped in by reading +-- their interface files +data ExternalPackageState + = EPS { + eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), + -- ^ In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else + -- + -- The 'ModuleName' part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from 'TcRnTypes.imp_dep_mods' + + eps_PIT :: !PackageIfaceTable, + -- ^ The 'ModIface's for modules in external packages + -- whose interfaces we have opened. + -- The declarations in these interface files are held in the + -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' + -- fields of this record, not in the 'mi_decls' fields of the + -- interface we have sucked in. + -- + -- What /is/ in the PIT is: + -- + -- * The Module + -- + -- * Fingerprint info + -- + -- * Its exports + -- + -- * Fixities + -- + -- * Deprecations and warnings + + eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), + -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on + -- the 'eps_PIT' for this information, EXCEPT that when + -- we do dependency analysis, we need to look at the + -- 'Dependencies' of our imports to determine what their + -- precise free holes are ('moduleFreeHolesPrecise'). We + -- don't want to repeatedly reread in the interface + -- for every import, so cache it here. When the PIT + -- gets filled in we can drop these entries. + + eps_PTE :: !PackageTypeEnv, + -- ^ Result of typechecking all the external package + -- interface files we have sucked in. The domain of + -- the mapping is external-package modules + + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated + -- from all the external-package modules + eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated + -- from all the external-package modules + eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated + -- from all the external-package modules + eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated + -- from all the external-package modules + eps_complete_matches :: !PackageCompleteMatchMap, + -- ^ The total 'CompleteMatchMap' accumulated + -- from all the external-package modules + + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external + -- packages, keyed off the module that declared them + + eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + } + +-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. +-- \"In\" means stuff that is just /read/ from interface files, +-- \"Out\" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- ^ Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } + +{- +Names in a NameCache are always stored as a Global, and have the SrcLoc +of their binding locations. + +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. +-} + +updNameCache :: IORef NameCache + -> (NameCache -> (NameCache, c)) -- The updating function + -> IO c +updNameCache ncRef upd_fn + = atomicModifyIORef' ncRef upd_fn + +mkSOName :: Platform -> FilePath -> FilePath +mkSOName platform root + = case platformOS platform of + OSMinGW32 -> root <.> soExt platform + _ -> ("lib" ++ root) <.> soExt platform + +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + +soExt :: Platform -> FilePath +soExt platform + = case platformOS platform of + OSDarwin -> "dylib" + OSMinGW32 -> "dll" + _ -> "so" + +{- +************************************************************************ +* * + The module graph and ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +* * +************************************************************************ +-} + +-- | A ModuleGraph contains all the nodes from the home package (only). +-- There will be a node for each source module, plus a node for each hi-boot +-- module. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. +data ModuleGraph = ModuleGraph + { mg_mss :: [ModSummary] + , mg_non_boot :: ModuleEnv ModSummary + -- a map of all non-boot ModSummaries keyed by Modules + , mg_boot :: ModuleSet + -- a set of boot Modules + , mg_needs_th_or_qq :: !Bool + -- does any of the modules in mg_mss require TemplateHaskell or + -- QuasiQuotes? + } + +-- | Determines whether a set of modules requires Template Haskell or +-- Quasi Quotes +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskellOrQQ :: ModuleGraph -> Bool +needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg + +-- | Map a function 'f' over all the 'ModSummaries'. +-- To preserve invariants 'f' can't change the isBoot status. +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG f mg@ModuleGraph{..} = mg + { mg_mss = map f mg_mss + , mg_non_boot = mapModuleEnv f mg_non_boot + } + +mgBootModules :: ModuleGraph -> ModuleSet +mgBootModules ModuleGraph{..} = mg_boot + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries = mg_mss + +mgElemModule :: ModuleGraph -> Module -> Bool +mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot + +-- | Look up a ModSummary in the ModuleGraph +mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary +mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m + +emptyMG :: ModuleGraph +emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False + +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool +isTemplateHaskellOrQQNonBoot ms = + (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) + || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && + not (isBootSummary ms) + +-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is +-- not an element of the ModuleGraph. +extendMG :: ModuleGraph -> ModSummary -> ModuleGraph +extendMG ModuleGraph{..} ms = ModuleGraph + { mg_mss = ms:mg_mss + , mg_non_boot = if isBootSummary ms + then mg_non_boot + else extendModuleEnv mg_non_boot (ms_mod ms) ms + , mg_boot = if isBootSummary ms + then extendModuleSet mg_boot (ms_mod ms) + else mg_boot + , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms + } + +mkModuleGraph :: [ModSummary] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG) emptyMG + +-- | A single node in a 'ModuleGraph'. The nodes of the module graph +-- are one of: +-- +-- * A regular Haskell source module +-- * A hi-boot source module +-- +data ModSummary + = ModSummary { + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell or hs-boot + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_date :: UTCTime, + -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_iface_date :: Maybe UTCTime, + -- ^ Timestamp of hi file, if we *only* are typechecking (it is + -- 'Nothing' otherwise. + -- See Note [Recompilation checking in -fno-code mode] and #9243 + ms_hie_date :: Maybe UTCTime, + -- ^ Timestamp of hie file, if we have one + ms_srcimps :: [(Maybe FastString, Located ModuleName)], + -- ^ Source imports of the module + ms_textual_imps :: [(Maybe FastString, Located ModuleName)], + -- ^ Non-source imports of the module from the module *text* + ms_parsed_mod :: Maybe HsParsedModule, + -- ^ The parsed, nonrenamed source, if we have it. This is also + -- used to support "inline module syntax" in Backpack files. + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it + } + +ms_installed_mod :: ModSummary -> InstalledModule +ms_installed_mod = fst . splitModuleInsts . ms_mod + +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] +ms_imps ms = + ms_textual_imps ms ++ + map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + mk_additional_import mod_nm = (Nothing, noLoc mod_nm) + +home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] +home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, + isLocal mb_pkg ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +-- | Like 'ms_home_imps', but for SOURCE imports. +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +-- | All of the (possibly) home module imports from a +-- 'ModSummary'; that is to say, each of these module names +-- could be a home import if an appropriately named file +-- existed. (This is in contrast to package qualified +-- imports, which are guaranteed not to be home imports.) +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + +msDynObjFilePath :: ModSummary -> DynFlags -> FilePath +msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) + +-- | Did this 'ModSummary' originate from a hs-boot file? +isBootSummary :: ModSummary -> Bool +isBootSummary ms = ms_hsc_src ms == HsBootFile + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary = showSDoc dflags $ + if gopt Opt_HideSourcePaths dflags + then text mod_str + else hsep $ + [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') + , char '(' + , text (op $ msHsFilePath mod_summary) <> char ',' + ] ++ + if gopt Opt_BuildDynamicToo dflags + then [ text obj_file <> char ',' + , text dyn_file + , char ')' + ] + else [ text obj_file, char ')' ] + where + op = normalise + mod = moduleName (ms_mod mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + dyn_file = op $ msDynObjFilePath mod_summary dflags + obj_file = case target of + HscInterpreted | recomp -> "interpreted" + HscNothing -> "nothing" + _ -> (op $ msObjFilePath mod_summary) + +{- +************************************************************************ +* * +\subsection{Recompilation} +* * +************************************************************************ +-} + +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. + +{- +************************************************************************ +* * +\subsection{Hpc Support} +* * +************************************************************************ +-} + +-- | Information about a modules use of Haskell Program Coverage +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? + } + +-- | This is used to signal if one of my imports used HPC instrumentation +-- even if there is no module-local HPC usage +type AnyHpcUsage = Bool + +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +-- | Find out if HPC is used by this module or any of the modules +-- it depends upon +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used + +{- +************************************************************************ +* * +\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. +-} + +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | 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_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_SafeInferred -> 4 + Sf_Ignore -> 0 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_Unsafe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo 4 = setSafeMode Sf_SafeInferred +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = text "none" + ppr (TrustInfo Sf_Ignore) = text "none" + ppr (TrustInfo Sf_Unsafe) = text "unsafe" + ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" + ppr (TrustInfo Sf_Safe) = text "safe" + ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) + +{- +************************************************************************ +* * +\subsection{Parser result} +* * +************************************************************************ +-} + +data HsParsedModule = HsParsedModule { + hpm_module :: Located HsModule, + hpm_src_files :: [FilePath], + -- ^ extra source files (e.g. from #includes). The lexer collects + -- these from '# <file> <line>' pragmas, which the C preprocessor + -- leaves behind. These files and their timestamps are stored in + -- the .hi file, so that we can force recompilation if any of + -- them change (#3589) + hpm_annotations :: ApiAnns + -- See note [Api annotations] in ApiAnnotation.hs + } + +{- +************************************************************************ +* * +\subsection{Linkable stuff} +* * +************************************************************************ + +This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler +-} + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in HscNothing mode, and this choice + -- happens to work well with checkStability in module GHC. + +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + +------------------------------------------- + +-- | Is this an actual file on disk we can link in somehow? +isObject :: Unlinked -> Bool +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +-- | Is this a bytecode linkable with no file on disk? +isInterpretable :: Unlinked -> Bool +isInterpretable = not . isObject + +-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object +nameOfObject :: Unlinked -> FilePath +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn +nameOfObject other = pprPanic "nameOfObject" (ppr other) + +-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + + +------------------------------------------- + +-- | A list of conlikes which represents a complete pattern match. +-- These arise from @COMPLETE@ signatures. + +-- See Note [Implementation of COMPLETE signatures] +data CompleteMatch = CompleteMatch { + completeMatchConLikes :: [Name] + -- ^ The ConLikes that form a covering family + -- (e.g. Nothing, Just) + , completeMatchTyCon :: Name + -- ^ The TyCon that they cover (e.g. Maybe) + } + +instance Outputable CompleteMatch where + ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl + <+> dcolon <+> ppr ty + +-- | A map keyed by the 'completeMatchTyCon'. + +-- See Note [Implementation of COMPLETE signatures] +type CompleteMatchMap = UniqFM [CompleteMatch] + +mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap +mkCompleteMatchMap = extendCompleteMatchMap emptyUFM + +extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] + -> CompleteMatchMap +extendCompleteMatchMap = foldl' insertMatch + where + insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap + insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] + +{- +Note [Implementation of COMPLETE signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A COMPLETE signature represents a set of conlikes (i.e., constructors or +pattern synonyms) such that if they are all pattern-matched against in a +function, it gives rise to a total function. An example is: + + newtype Boolean = Boolean Int + pattern F, T :: Boolean + pattern F = Boolean 0 + pattern T = Boolean 1 + {-# COMPLETE F, T #-} + + -- This is a total function + booleanToInt :: Boolean -> Int + booleanToInt F = 0 + booleanToInt T = 1 + +COMPLETE sets are represented internally in GHC with the CompleteMatch data +type. For example, {-# COMPLETE F, T #-} would be represented as: + + CompleteMatch { complateMatchConLikes = [F, T] + , completeMatchTyCon = Boolean } + +Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the +cases in which it's ambiguous, you can also explicitly specify it in the source +language by writing this: + + {-# COMPLETE F, T :: Boolean #-} + +For efficiency purposes, GHC collects all of the CompleteMatches that it knows +about into a CompleteMatchMap, which is a map that is keyed by the +completeMatchTyCon. In other words, you could have a multiple COMPLETE sets +for the same TyCon: + + {-# COMPLETE F, T1 :: Boolean #-} + {-# COMPLETE F, T2 :: Boolean #-} + +And looking up the values in the CompleteMatchMap associated with Boolean +would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. +dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup. + +Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed +explanation for how GHC ensures that all the conlikes in a COMPLETE set are +consistent. +-} + +-- | Foreign language of the phase if the phase deals with a foreign code +phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang +phaseForeignLanguage phase = case phase of + Phase.Cc -> Just LangC + Phase.Ccxx -> Just LangCxx + Phase.Cobjc -> Just LangObjc + Phase.Cobjcxx -> Just LangObjcxx + Phase.HCc -> Just LangC + Phase.As _ -> Just LangAsm + Phase.MergeForeign -> Just RawObject + _ -> Nothing + +------------------------------------------- + +-- Take care, this instance only forces to the degree necessary to +-- avoid major space leaks. +instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where + rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = + rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` + f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` + rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 |