diff options
Diffstat (limited to 'compiler/main')
34 files changed, 21 insertions, 23307 deletions
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs deleted file mode 100644 index d2cc56f033..0000000000 --- a/compiler/main/CmdLineParser.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -------------------------------------------------------------------------------- --- --- | Command-line parser --- --- This is an abstract command-line parser used by DynFlags. --- --- (c) The University of Glasgow 2005 --- -------------------------------------------------------------------------------- - -module CmdLineParser - ( - 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/main/CodeOutput.hs b/compiler/main/CodeOutput.hs deleted file mode 100644 index de5452740e..0000000000 --- a/compiler/main/CodeOutput.hs +++ /dev/null @@ -1,264 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section{Code output phase} --} - -{-# LANGUAGE CPP #-} - -module CodeOutput( codeOutput, outputForeignStubs ) where - -#include "HsVersions.h" - -import GhcPrelude - -import AsmCodeGen ( nativeCodeGen ) -import GHC.CmmToLlvm ( llvmCodeGen ) - -import UniqSupply ( mkSplitUniqSupply ) - -import Finder ( mkStubPaths ) -import GHC.CmmToC ( writeC ) -import GHC.Cmm.Lint ( cmmLint ) -import Packages -import GHC.Cmm ( RawCmmGroup ) -import HscTypes -import DynFlags -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/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs deleted file mode 100644 index 04b438c018..0000000000 --- a/compiler/main/DriverMkDepend.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Makefile Dependency Generation --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module DriverMkDepend ( - doMkDependHS - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import qualified GHC -import GhcMonad -import DynFlags -import Util -import HscTypes -import qualified SysTools -import Module -import Digraph ( SCC(..) ) -import 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/main/DriverPhases.hs b/compiler/main/DriverPhases.hs deleted file mode 100644 index 5c88faf895..0000000000 --- a/compiler/main/DriverPhases.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ --- --- GHC Driver --- --- (c) The University of Glasgow 2002 --- ------------------------------------------------------------------------------ - -module DriverPhases ( - 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 #-} DynFlags -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 -DriverPipeline.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/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs deleted file mode 100644 index 99a3ae9b70..0000000000 --- a/compiler/main/DriverPipeline.hs +++ /dev/null @@ -1,2340 +0,0 @@ -{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module DriverPipeline ( - -- 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 PipelineMonad -import Packages -import HeaderInfo -import DriverPhases -import SysTools -import SysTools.ExtraObj -import HscMain -import Finder -import HscTypes hiding ( Hsc ) -import Outputable -import Module -import ErrUtils -import DynFlags -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 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 (DriverPipeline.joinObjectFiles) - - * When assembling (DriverPipeline.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/main/DynFlags.hs b/compiler/main/DynFlags.hs deleted file mode 100644 index 42205ac0b2..0000000000 --- a/compiler/main/DynFlags.hs +++ /dev/null @@ -1,5939 +0,0 @@ -{-# 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 DynFlags ( - -- * 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 #-} Plugins -import {-# SOURCE #-} Hooks -import {-# SOURCE #-} PrelNames ( mAIN ) -import {-# SOURCE #-} Packages (PackageState, emptyPackageState, PackageDatabase) -import DriverPhases ( Phase(..), phaseInputExt ) -import Config -import CliOption -import CmdLineParser hiding (WarnReason(..)) -import qualified CmdLineParser 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 'DriverPipeline.runPipeline' based on where - -- its output is going. - dumpPrefix :: Maybe FilePath, - - -- | Override the 'dumpPrefix' set by 'DriverPipeline.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 [HscMain . 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/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot deleted file mode 100644 index 6d471f3970..0000000000 --- a/compiler/main/DynFlags.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module DynFlags 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/main/Elf.hs b/compiler/main/Elf.hs index 9e19de12dd..e9c80d7d81 100644 --- a/compiler/main/Elf.hs +++ b/compiler/main/Elf.hs @@ -18,7 +18,7 @@ import GhcPrelude import AsmUtils import Exception -import DynFlags +import GHC.Driver.Session import ErrUtils import Maybes (MaybeT(..),runMaybeT) import Util (charToC) diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 320912ba59..5adc4c61f4 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -72,7 +72,7 @@ import Outputable import Panic import qualified PprColour as Col import SrcLoc -import DynFlags +import GHC.Driver.Session import FastString (unpackFS) import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import Json @@ -552,7 +552,7 @@ chooseDumpFile dflags dumpOpt -- by the --ddump-file-prefix flag. | Just prefix <- dumpPrefixForce dflags = Just prefix - -- dump file location chosen by DriverPipeline.runPipeline + -- dump file location chosen by GHC.Driver.Pipeline.runPipeline | Just prefix <- dumpPrefix dflags = Just prefix -- we haven't got a place to put a dump file. diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot index a2ba51b304..e071d09272 100644 --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -6,7 +6,7 @@ import GhcPrelude import Outputable (SDoc, PprStyle ) import SrcLoc (SrcSpan) import Json -import {-# SOURCE #-} DynFlags ( DynFlags ) +import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String -> DumpFormat -> SDoc -> IO () diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs index 35bed6149b..81d0ce7a40 100644 --- a/compiler/main/FileCleanup.hs +++ b/compiler/main/FileCleanup.hs @@ -9,12 +9,12 @@ module FileCleanup import GhcPrelude -import DynFlags +import GHC.Driver.Session import ErrUtils import Outputable import Util import Exception -import DriverPhases +import GHC.Driver.Phases import Control.Monad import Data.List diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs deleted file mode 100644 index 05d99a6a21..0000000000 --- a/compiler/main/Finder.hs +++ /dev/null @@ -1,844 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 - -\section[Finder]{Module Finder} --} - -{-# LANGUAGE CPP #-} - -module 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 HscTypes -import Packages -import FastString -import Util -import PrelNames ( gHC_PRIM ) -import DynFlags -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/main/GHC.hs b/compiler/main/GHC.hs deleted file mode 100644 index b15803eed1..0000000000 --- a/compiler/main/GHC.hs +++ /dev/null @@ -1,1705 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# LANGUAGE TupleSections, NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2012 --- --- The GHC API --- --- ----------------------------------------------------------------------------- - -module GHC ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, - prettyPrintGhcErrors, - withSignalHandlers, - withCleanupSession, - - -- * GHC Monad - Ghc, GhcT, GhcMonad(..), HscEnv, - runGhc, runGhcT, initGhcMonad, - gcatch, gbracket, gfinally, - printException, - handleSourceError, - needsTemplateHaskellOrQQ, - - -- * Flags and settings - DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt, - GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, setSessionDynFlags, - getProgramDynFlags, setProgramDynFlags, setLogAction, - getInteractiveDynFlags, setInteractiveDynFlags, - interpretPackageEnv, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Loading\/compiling the program - depanal, depanalE, - load, LoadHowMuch(..), InteractiveImport(..), - SuccessFlag(..), succeeded, failed, - defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, - parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), - TypecheckedSource, ParsedSource, RenamedSource, -- ditto - TypecheckedMod, ParsedMod, - moduleInfo, renamedSource, typecheckedSource, - parsedSource, coreModule, - - -- ** Compiling to Core - CoreModule(..), - compileToCoreModule, compileToCoreSimplified, - - -- * Inspecting the module structure of the program - ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, - mgLookupModule, - ModSummary(..), ms_mod_name, ModLocation(..), - getModSummary, - getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, - modInfoExports, - modInfoExportsWithSelectors, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, - modInfoIface, - modInfoRdrEnv, - modInfoSafe, - lookupGlobalName, - findGlobalAnns, - mkPrintUnqualifiedForModule, - ModIface, ModIface_(..), - SafeHaskellMode(..), - - -- * Querying the environment - -- packageDbModules, - - -- * Printing - PrintUnqualified, alwaysQualify, - - -- * Interactive evaluation - - -- ** Executing statements - execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), - resumeExec, - - -- ** Adding new declarations - runDecls, runDeclsWithLocation, runParsedDecls, - - -- ** Get/set the current context - parseImportDecl, - setContext, getContext, - setGHCiMonad, getGHCiMonad, - - -- ** Inspecting the current context - getBindings, getInsts, getPrintUnqual, - findModule, lookupModule, - isModuleTrusted, moduleTrustReqs, - getNamesInScope, - getRdrNamesInScope, - getGRE, - moduleIsInterpreted, - getInfo, - showModule, - moduleIsBootOrNotObjectLinkable, - getNameToInstancesIndex, - - -- ** Inspecting types and kinds - exprType, TcRnExprMode(..), - typeKind, - - -- ** Looking up a Name - parseName, - lookupName, - - -- ** Compiling expressions - HValue, parseExpr, compileParsedExpr, - GHC.Runtime.Eval.compileExpr, dynCompileExpr, - ForeignHValue, - compileExprRemote, compileParsedExprRemote, - - -- ** Docs - getDocs, GetDocsFailure(..), - - -- ** Other - runTcInteractive, -- Desired by some clients (#8878) - isStmt, hasImport, isImport, isDecl, - - -- ** The debugger - SingleStep(..), - Resume(..), - History(historyBreakInfo, historyEnclosingDecls), - GHC.getHistorySpan, getHistoryModule, - abandon, abandonAll, - getResumeContext, - GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, - modInfoModBreaks, - ModBreaks(..), BreakIndex, - BreakInfo(breakInfo_number, breakInfo_module), - GHC.Runtime.Eval.back, - GHC.Runtime.Eval.forward, - - -- * Abstract syntax elements - - -- ** Packages - UnitId, - - -- ** Modules - Module, mkModule, pprModule, moduleName, moduleUnitId, - ModuleName, mkModuleName, moduleNameString, - - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorTyCon, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, - isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, - tyConClass_maybe, - synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, - dataConSrcBangs, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, classATs, - pprFundeps, - - -- ** Instances - ClsInst, - instanceDFunId, - pprInstance, pprInstanceHdr, - pprFamInst, - - FamInst, - - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprForAll, pprThetaArrowTy, - parseInstanceHead, - getInstancesForType, - - -- ** Entities - TyThing(..), - - -- ** Syntax - module GHC.Hs, -- ToDo: remove extraneous bits - - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, - LexicalFixity(..), - - -- ** Source locations - SrcLoc(..), RealSrcLoc, - mkSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, - SrcSpan(..), RealSrcSpan, - mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, - srcSpanStart, srcSpanEnd, - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Located - GenLocated(..), Located, - - -- *** Constructing Located - noLoc, mkGeneralLocated, - - -- *** Deconstructing Located - getLoc, unLoc, - getRealSrcSpan, unRealSrcSpan, - - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf, - - -- * Exceptions - GhcException(..), showGhcException, - - -- * Token stream manipulations - Token, - getTokenStream, getRichTokenStream, - showRichTokenStream, addSourceToTokens, - - -- * Pure interface to the parser - parser, - - -- * API Annotations - ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments, getAndRemoveAnnotationComments, - unicodeAnn, - - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, - ) where - -{- - ToDo: - - * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. --} - -#include "HsVersions.h" - -import GhcPrelude hiding (init) - -import GHC.ByteCode.Types -import GHC.Runtime.Eval -import GHC.Runtime.Eval.Types -import GHC.Runtime.Interpreter -import GHCi.RemoteTypes - -import PprTyThing ( pprFamInst ) -import HscMain -import GhcMake -import DriverPipeline ( compileOne' ) -import GhcMonad -import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) -import GHC.Iface.Load ( loadSysInterface ) -import TcRnTypes -import Predicate -import Packages -import NameSet -import RdrName -import GHC.Hs -import Type hiding( typeKind ) -import TcType -import Id -import TysPrim ( alphaTyVars ) -import TyCon -import TyCoPpr ( pprForAll ) -import Class -import DataCon -import Name hiding ( varName ) -import Avail -import InstEnv -import FamInstEnv ( FamInst ) -import SrcLoc -import CoreSyn -import GHC.Iface.Tidy -import DriverPhases ( Phase(..), isHaskellSrcFilename ) -import Finder -import HscTypes -import CmdLineParser -import DynFlags hiding (WarnReason(..)) -import SysTools -import SysTools.BaseDir -import Annotations -import Module -import Panic -import GHC.Platform -import Bag ( listToBag ) -import ErrUtils -import MonadUtils -import Util -import StringBuffer -import Outputable -import BasicTypes -import FastString -import qualified Parser -import Lexer -import ApiAnnotation -import qualified GHC.LanguageExtensions as LangExt -import NameEnv -import CoreFVs ( orphNamesOfFamInst ) -import FamInstEnv ( famInstEnvElts ) -import TcRnDriver -import Inst -import FamInst -import FileCleanup - -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Sequence as Seq -import Data.Maybe -import Data.Time -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad -import System.Exit ( exitWith, ExitCode(..) ) -import Exception -import Data.IORef -import System.FilePath - -import Maybes -import System.IO.Error ( isDoesNotExistError ) -import System.Environment ( getEnv ) -import System.Directory - - --- %************************************************************************ --- %* * --- Initialisation: exception handlers --- %* * --- %************************************************************************ - - --- | Install some default exception handlers and run the inner computation. --- Unless you want to handle exceptions yourself, you should wrap this around --- the top level of your program. The default handlers output the error --- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m) - => FatalMessager -> FlushOut -> m a -> m a -defaultErrorHandler fm (FlushOut flushOut) inner = - -- top-level exception handler: any unrecognised exception is a compiler bug. - ghandle (\exception -> liftIO $ do - flushOut - case fromException exception of - -- an IO exception probably isn't our fault, so don't panic - Just (ioe :: IOException) -> - fatalErrorMsg'' fm (show ioe) - _ -> case fromException exception of - Just UserInterrupt -> - -- Important to let this one propagate out so our - -- calling process knows we were interrupted by ^C - liftIO $ throwIO UserInterrupt - Just StackOverflow -> - fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it" - _ -> case fromException exception of - Just (ex :: ExitCode) -> liftIO $ throwIO ex - _ -> - fatalErrorMsg'' fm - (show (Panic (show exception))) - exitWith (ExitFailure 1) - ) $ - - -- error messages propagated as exceptions - handleGhcException - (\ge -> liftIO $ do - flushOut - case ge of - Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg'' fm (show ge) - exitWith (ExitFailure 1) - ) $ - inner - --- | This function is no longer necessary, cleanup is now done by --- runGhc/runGhcT. -{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} -defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a -defaultCleanupHandler _ m = m - where _warning_suppression = m `gonException` undefined - - --- %************************************************************************ --- %* * --- The Ghc Monad --- %* * --- %************************************************************************ - --- | Run function for the 'Ghc' monad. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. --- --- Any errors not handled inside the 'Ghc' action are propagated as IO --- exceptions. - -runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> Ghc a -- ^ The action to perform. - -> IO a -runGhc mb_top_dir ghc = do - ref <- newIORef (panic "empty session") - let session = Session ref - flip unGhc session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghc - --- | Run function for 'GhcT' monad transformer. --- --- It initialises the GHC session and warnings via 'initGhcMonad'. Each call --- to this function will create a new session which should not be shared among --- several threads. - -runGhcT :: ExceptionMonad m => - Maybe FilePath -- ^ See argument to 'initGhcMonad'. - -> GhcT m a -- ^ The action to perform. - -> m a -runGhcT mb_top_dir ghct = do - ref <- liftIO $ newIORef (panic "empty session") - let session = Session ref - flip unGhcT session $ withSignalHandlers $ do -- catch ^C - initGhcMonad mb_top_dir - withCleanupSession ghct - -withCleanupSession :: GhcMonad m => m a -> m a -withCleanupSession ghc = ghc `gfinally` cleanup - where - cleanup = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags - stopIServ hsc_env -- shut down the IServ - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - --- | Initialise a GHC session. --- --- If you implement a custom 'GhcMonad' you must call this function in the --- monad run function. It will initialise the session variable and clear all --- warnings. --- --- The first argument should point to the directory where GHC's library files --- reside. More precisely, this should be the output of @ghc --print-libdir@ --- of the version of GHC the module using this API is compiled with. For --- portability, you should use the @ghc-paths@ package, available at --- <http://hackage.haskell.org/package/ghc-paths>. - -initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir - = do { env <- liftIO $ - do { top_dir <- findTopDir mb_top_dir - ; mySettings <- initSysTools top_dir - ; myLlvmConfig <- lazyInitLlvmConfig top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; checkBrokenTablesNextToCode dflags - ; setUnsafeGlobalDynFlags dflags - -- c.f. DynFlags.parseDynamicFlagsFull, which - -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; newHscEnv dflags } - ; setSession env } - --- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which --- breaks tables-next-to-code in dynamically linked modules. This --- check should be more selective but there is currently no released --- version where this bug is fixed. --- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and --- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () -checkBrokenTablesNextToCode dflags - = do { broken <- checkBrokenTablesNextToCode' dflags - ; when broken - $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr - ; liftIO $ fail "unsupported linker" - } - } - where - invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> - text "when using binutils ld (please see:" <+> - text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool -checkBrokenTablesNextToCode' dflags - | not (isARM arch) = return False - | WayDyn `notElem` ways dflags = return False - | not (tablesNextToCode dflags) = return False - | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - - --- %************************************************************************ --- %* * --- Flags & settings --- %* * --- %************************************************************************ - --- $DynFlags --- --- The GHC session maintains two sets of 'DynFlags': --- --- * The "interactive" @DynFlags@, which are used for everything --- related to interactive evaluation, including 'runStmt', --- 'runDecls', 'exprType', 'lookupName' and so on (everything --- under \"Interactive evaluation\" in this module). --- --- * The "program" @DynFlags@, which are used when loading --- whole modules with 'load' --- --- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the --- interactive @DynFlags@. --- --- 'setProgramDynFlags', 'getProgramDynFlags' work with the --- program @DynFlags@. --- --- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' --- retrieves the program @DynFlags@ (for backwards compatibility). - - --- | Updates both the interactive and program DynFlags in a Session. --- This also reads the package database (unless it has already been --- read), and prepares the compilers knowledge about packages. It can --- be called again to load new packages: just add new package flags to --- (packageFlags dflags). --- --- Returns a list of new packages that may need to be linked in using --- the dynamic linker (see 'linkPackages') as a result of new package --- flags. If you are not doing linking or doing static linking, you --- can ignore the list of packages returned. --- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setSessionDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- liftIO $ interpretPackageEnv dflags' - (dflags''', preload) <- liftIO $ initPackages dflags'' - modifySession $ \h -> h{ hsc_dflags = dflags''' - , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } } - invalidateModSummaryCache - return preload - --- | Sets the program 'DynFlags'. Note: this invalidates the internal --- cached module graph, causing more work to be done the next time --- 'load' is called. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] -setProgramDynFlags dflags = setProgramDynFlags_ True dflags - --- | Set the action taken when the compiler produces a message. This --- can also be accomplished using 'setProgramDynFlags', but using --- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> m () -setLogAction action = do - dflags' <- getProgramDynFlags - void $ setProgramDynFlags_ False $ - dflags' { log_action = action } - -setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] -setProgramDynFlags_ invalidate_needed dflags = do - dflags' <- checkNewDynFlags dflags - dflags_prev <- getProgramDynFlags - (dflags'', preload) <- - if (packageFlagsChanged dflags_prev dflags') - then liftIO $ initPackages dflags' - else return (dflags', []) - modifySession $ \h -> h{ hsc_dflags = dflags'' } - when invalidate_needed $ invalidateModSummaryCache - return preload - - --- When changing the DynFlags, we want the changes to apply to future --- loads, but without completely discarding the program. But the --- DynFlags are cached in each ModSummary in the hsc_mod_graph, so --- after a change to DynFlags, the changes would apply to new modules --- but not existing modules; this seems undesirable. --- --- Furthermore, the GHC API client might expect that changing --- log_action would affect future compilation messages, but for those --- modules we have cached ModSummaries for, we'll continue to use the --- old log_action. This is definitely wrong (#7478). --- --- Hence, we invalidate the ModSummary cache after changing the --- DynFlags. We do this by tweaking the date on each ModSummary, so --- that the next downsweep will think that all the files have changed --- and preprocess them again. This won't necessarily cause everything --- to be recompiled, because by the time we check whether we need to --- recompile a module, we'll have re-summarised the module and have a --- correct ModSummary. --- -invalidateModSummaryCache :: GhcMonad m => m () -invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } - where - inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } - --- | Returns the program 'DynFlags'. -getProgramDynFlags :: GhcMonad m => m DynFlags -getProgramDynFlags = getSessionDynFlags - --- | Set the 'DynFlags' used to evaluate interactive expressions. --- Note: this cannot be used for changes to packages. Use --- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the --- 'pkgState' into the interactive @DynFlags@. -setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () -setInteractiveDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- checkNewInteractiveDynFlags dflags' - modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }} - --- | Get the 'DynFlags' used to evaluate interactive expressions. -getInteractiveDynFlags :: GhcMonad m => m DynFlags -getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) - - -parseDynamicFlags :: MonadIO m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlags = parseDynamicFlagsCmdLine - --- | Checks the set of new DynFlags for possibly erroneous option --- combinations when invoking 'setSessionDynFlags' and friends, and if --- found, returns a fixed copy (if possible). -checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewDynFlags dflags = do - -- See Note [DynFlags consistency] - let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings) - return dflags' - -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewInteractiveDynFlags dflags0 = do - -- We currently don't support use of StaticPointers in expressions entered on - -- the REPL. See #12356. - if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowWarnings dflags0 $ listToBag - [mkPlainWarnMsg dflags0 interactiveSrcSpan - $ text "StaticPointers is not supported in GHCi interactive expressions."] - return $ xopt_unset dflags0 LangExt.StaticPointers - else return dflags0 - - --- %************************************************************************ --- %* * --- Setting, getting, and modifying the targets --- %* * --- %************************************************************************ - --- ToDo: think about relative vs. absolute file paths. And what --- happens when the current directory changes. - --- | Sets the targets for this session. Each target may be a module name --- or a filename. The targets correspond to the set of root modules for --- the program\/library. Unloading the current program is achieved by --- setting the current set of targets to be empty, followed by 'load'. -setTargets :: GhcMonad m => [Target] -> m () -setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) - --- | Returns the current set of targets -getTargets :: GhcMonad m => m [Target] -getTargets = withSession (return . hsc_targets) - --- | Add another target. -addTarget :: GhcMonad m => Target -> m () -addTarget target - = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) - --- | Remove a target -removeTarget :: GhcMonad m => TargetId -> m () -removeTarget target_id - = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) - where - filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] - --- | Attempts to guess what Target a string refers to. This function --- implements the @--make@/GHCi command-line syntax for filenames: --- --- - if the string looks like a Haskell source filename, then interpret it --- as such --- --- - if adding a .hs or .lhs suffix yields the name of an existing file, --- then use that --- --- - otherwise interpret the string as a module name --- -guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target -guessTarget str (Just phase) - = return (Target (TargetFile str (Just phase)) True Nothing) -guessTarget str Nothing - | isHaskellSrcFilename file - = return (target (TargetFile file Nothing)) - | otherwise - = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do - if looksLikeModuleName file - then return (target (TargetModule (mkModuleName file))) - else do - dflags <- getDynFlags - liftIO $ throwGhcExceptionIO - (ProgramError (showSDoc dflags $ - text "target" <+> quotes (text file) <+> - text "is not a module name or a source file")) - where - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) - - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" - - target tid = Target tid obj_allowed Nothing - - --- | Inform GHC that the working directory has changed. GHC will flush --- its cache of module locations, since it may no longer be valid. --- --- Note: Before changing the working directory make sure all threads running --- in the same session have stopped. If you change the working directory, --- you should also unload the current program (set targets to empty, --- followed by load). -workingDirectoryChanged :: GhcMonad m => m () -workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) - - --- %************************************************************************ --- %* * --- Running phases one at a time --- %* * --- %************************************************************************ - -class ParsedMod m where - modSummary :: m -> ModSummary - parsedSource :: m -> ParsedSource - -class ParsedMod m => TypecheckedMod m where - renamedSource :: m -> Maybe RenamedSource - typecheckedSource :: m -> TypecheckedSource - moduleInfo :: m -> ModuleInfo - tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. - -class TypecheckedMod m => DesugaredMod m where - coreModule :: m -> ModGuts - --- | The result of successful parsing. -data ParsedModule = - ParsedModule { pm_mod_summary :: ModSummary - , pm_parsed_source :: ParsedSource - , pm_extra_src_files :: [FilePath] - , pm_annotations :: ApiAnns } - -- See Note [Api annotations] in ApiAnnotation.hs - -instance ParsedMod ParsedModule where - modSummary m = pm_mod_summary m - parsedSource m = pm_parsed_source m - --- | The result of successful typechecking. It also contains the parser --- result. -data TypecheckedModule = - TypecheckedModule { tm_parsed_module :: ParsedModule - , tm_renamed_source :: Maybe RenamedSource - , tm_typechecked_source :: TypecheckedSource - , tm_checked_module_info :: ModuleInfo - , tm_internals_ :: (TcGblEnv, ModDetails) - } - -instance ParsedMod TypecheckedModule where - modSummary m = modSummary (tm_parsed_module m) - parsedSource m = parsedSource (tm_parsed_module m) - -instance TypecheckedMod TypecheckedModule where - renamedSource m = tm_renamed_source m - typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m - tm_internals m = tm_internals_ m - --- | The result of successful desugaring (i.e., translation to core). Also --- contains all the information of a typechecked module. -data DesugaredModule = - DesugaredModule { dm_typechecked_module :: TypecheckedModule - , dm_core_module :: ModGuts - } - -instance ParsedMod DesugaredModule where - modSummary m = modSummary (dm_typechecked_module m) - parsedSource m = parsedSource (dm_typechecked_module m) - -instance TypecheckedMod DesugaredModule where - renamedSource m = renamedSource (dm_typechecked_module m) - typecheckedSource m = typecheckedSource (dm_typechecked_module m) - moduleInfo m = moduleInfo (dm_typechecked_module m) - tm_internals m = tm_internals_ (dm_typechecked_module m) - -instance DesugaredMod DesugaredModule where - coreModule m = dm_core_module m - -type ParsedSource = Located HsModule -type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString) -type TypecheckedSource = LHsBinds GhcTc - --- NOTE: --- - things that aren't in the output of the typechecker right now: --- - the export list --- - the imports --- - type signatures --- - type/data/newtype declarations --- - class declarations --- - instances --- - extra things in the typechecker's output: --- - default methods are turned into top-level decls. --- - dictionary bindings - --- | Return the 'ModSummary' of a module with the given name. --- --- The module must be part of the module graph (see 'hsc_mod_graph' and --- 'ModuleGraph'). If this is not the case, this function will throw a --- 'GhcApiError'. --- --- This function ignores boot modules and requires that there is only one --- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary -getModSummary mod = do - mg <- liftM hsc_mod_graph getSession - let mods_by_name = [ ms | ms <- mgModSummaries mg - , ms_mod_name ms == mod - , not (isBootSummary ms) ] - case mods_by_name of - [] -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") - [ms] -> return ms - multiple -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) - --- | Parse a module. --- --- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModSummary -> m ParsedModule -parseModule ms = do - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) - (hpm_annotations hpm)) - -- See Note [Api annotations] in ApiAnnotation.hs - --- | Typecheck and rename a parsed module. --- --- Throws a 'SourceError' if either fails. -typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule -typecheckModule pmod = do - let ms = modSummary pmod - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } - details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env - safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - - return $ - TypecheckedModule { - tm_internals_ = (tc_gbl_env, details), - tm_parsed_module = pmod, - tm_renamed_source = rn_info, - tm_typechecked_source = tcg_binds tc_gbl_env, - tm_checked_module_info = - ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = fixSafeInstances safe $ md_insts details, - minf_iface = Nothing, - minf_safe = safe, - minf_modBreaks = emptyModBreaks - }} - --- | Desugar a typechecked module. -desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule -desugarModule tcm = do - let ms = modSummary tcm - let (tcg, _) = tm_internals tcm - hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg - return $ - DesugaredModule { - dm_typechecked_module = tcm, - dm_core_module = guts - } - --- | Load a module. Input doesn't need to be desugared. --- --- A module must be loaded before dependent modules can be typechecked. This --- always includes generating a 'ModIface' and, depending on the --- 'DynFlags.hscTarget', may also include code generation. --- --- This function will always cause recompilation and will always overwrite --- previous compilation results (potentially files on disk). --- -loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod -loadModule tcm = do - let ms = modSummary tcm - let mod = ms_mod_name ms - let loc = ms_location ms - let (tcg, _details) = tm_internals tcm - - mb_linkable <- case ms_obj_date ms of - Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) - (ml_obj_file loc) t - return (Just l) - _otherwise -> return Nothing - - let source_modified | isNothing mb_linkable = SourceModified - | otherwise = SourceUnmodified - -- we can't determine stability here - - -- compile doesn't change the session - hsc_env <- getSession - mod_info <- liftIO $ compileOne' (Just tcg) Nothing - hsc_env ms 1 1 Nothing mb_linkable - source_modified - - modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } - return tcm - - --- %************************************************************************ --- %* * --- Dealing with Core --- %* * --- %************************************************************************ - --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: CoreProgram, - -- | Safe Haskell mode - cm_safe :: SafeHaskellMode - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, - cm_safe = sf}) - = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te - $$ vcat (map ppr cb) - --- | This is the way to get access to the Core bindings corresponding --- to a module. 'compileToCore' parses, typechecks, and --- desugars the module, then returns the resulting Core module (consisting of --- the module name, type declarations, and function declarations) if --- successful. -compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule -compileToCoreModule = compileCore False - --- | Like compileToCoreModule, but invokes the simplifier, so --- as to return simplified and tidied Core. -compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule -compileToCoreSimplified = compileCore True - -compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule -compileCore simplify fn = do - -- First, set the target to the desired filename - target <- guessTarget fn Nothing - addTarget target - _ <- load LoadAllTargets - -- Then find dependencies - modGraph <- depanal [] True - case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly? - do tm <- typecheckModule =<< parseModule modSummary - let tcg = fst (tm_internals tm) - (,) tcg . coreModule <$> desugarModule tm - liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ - if simplify - then do - -- If simplify is true: simplify (hscSimplify), then tidy - -- (tidyProgram). - hsc_env <- getSession - simpl_guts <- liftIO $ do - plugins <- readIORef (tcg_th_coreplugins tcg) - hscSimplify hsc_env plugins mod_guts - tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts - return $ Left tidy_guts - else - return $ Right mod_guts - - Nothing -> panic "compileToCoreModule: target FilePath not found in\ - module dependency graph" - where -- two versions, based on whether we simplify (thus run tidyProgram, - -- which returns a (CgGuts, ModDetails) pair, or not (in which case - -- we just have a ModGuts. - gutsToCoreModule :: SafeHaskellMode - -> Either (CgGuts, ModDetails) ModGuts - -> CoreModule - gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { - cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg, - cm_safe = safe_mode - } - gutsToCoreModule safe_mode (Right mg) = CoreModule { - cm_module = mg_module mg, - cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) - (mg_fam_insts mg), - cm_binds = mg_binds mg, - cm_safe = safe_mode - } - --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - --- | Return @True@ <==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> - return $! isJust (lookupHpt (hsc_HPT hsc_env) m) - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - return $ ic_instances (hsc_IC hsc_env) - -getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> - return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - let mg = hsc_mod_graph hsc_env - if mgElemModule mg mdl - then liftIO $ getHomeModuleInfo hsc_env mdl - else do - {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl - -- ToDo: we don't understand what the following comment means. - -- (SDM, 19/7/2011) - -- getPackageModuleInfo will attempt to find the interface, so - -- we don't want to call it for a home module, just in case there - -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. (ToDo: reinstate) - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks - })) - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] -modInfoTopLevelScope minf - = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkPrintUnqualifiedForModule :: GhcMonad m => - ModuleInfo - -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X -mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - -modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv -modInfoRdrEnv = minf_rdr_env - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks - -isDictonaryId :: Id -> Bool -isDictonaryId id - = case tcSplitSigmaTy (idType id) of { - (_tvs, _theta, tau) -> isDictTy tau } - --- | Looks up a global name: that is, any top-level name in any --- visible module. Unlike 'lookupName', lookupGlobalName does not use --- the interactive context, and therefore does not require a preceding --- 'setContext'. -lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupGlobalName name = withSession $ \hsc_env -> do - liftIO $ lookupTypeHscEnv hsc_env name - -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] -findGlobalAnns deserialize target = withSession $ \hsc_env -> do - ann_env <- liftIO $ prepareAnnotations hsc_env Nothing - return (findAnns deserialize ann_env target) - --- | get the GlobalRdrEnv for a session -getGRE :: GhcMonad m => m GlobalRdrEnv -getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) - --- | Retrieve all type and family instances in the environment, indexed --- by 'Name'. Each name's lists will contain every instance in which that name --- is mentioned in the instance head. -getNameToInstancesIndex :: GhcMonad m - => [Module] -- ^ visible modules. An orphan instance will be returned - -- if it is visible from at least one module in the list. - -> Maybe [Module] -- ^ modules to load. If this is not specified, we load - -- modules for everything that is in scope unqualified. - -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) -getNameToInstancesIndex visible_mods mods_to_load = do - hsc_env <- getSession - liftIO $ runTcInteractive hsc_env $ - do { case mods_to_load of - Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) - Just mods -> - let doc = text "Need interface for reporting instances in scope" - in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods - - ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs - ; let visible_mods' = mkModuleSet visible_mods - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- We use Data.Sequence.Seq because we are creating left associated - -- mappends. - -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts - ; let cls_index = Map.fromListWith mappend - [ (n, Seq.singleton ispec) - | ispec <- instEnvElts ie_local ++ instEnvElts ie_global - , instIsVisible visible_mods' ispec - , n <- nameSetElemsStable $ orphNamesOfClsInst ispec - ] - ; let fam_index = Map.fromListWith mappend - [ (n, Seq.singleton fispec) - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , n <- nameSetElemsStable $ orphNamesOfFamInst fispec - ] - ; return $ mkNameEnv $ - [ (nm, (toList clss, toList fams)) - | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend - (fmap (,Seq.empty) cls_index) - (fmap (Seq.empty,) fam_index) - ] } - --- ----------------------------------------------------------------------------- - -{- ToDo: Move the primary logic here to compiler/main/Packages.hs --- | Return all /external/ modules available in the package database. --- Modules from the current session (i.e., from the 'HomePackageTable') are --- not included. This includes module names which are reexported by packages. -packageDbModules :: GhcMonad m => - Bool -- ^ Only consider exposed packages. - -> m [Module] -packageDbModules only_exposed = do - dflags <- getSessionDynFlags - let pkgs = eltsUFM (unitInfoMap (pkgState dflags)) - return $ - [ mkModule pid modname - | p <- pkgs - , not only_exposed || exposed p - , let pid = packageConfigId p - , modname <- exposedModules p - ++ map exportName (reexportedModules p) ] - -} - --- ----------------------------------------------------------------------------- --- Misc exported utils - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - --- | print a 'NamedThing', adding parentheses if the name is an operator. -pprParenSymName :: NamedThing a => a -> SDoc -pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) - --- ---------------------------------------------------------------------------- - - --- ToDo: --- - Data and Typeable instances for HsSyn. - --- ToDo: check for small transformations that happen to the syntax in --- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) - --- ToDo: maybe use TH syntax instead of Iface syntax? There's already a way --- to get from TyCons, Ids etc. to TH syntax (reify). - --- :browse will use either lm_toplev or inspect lm_interface, depending --- on whether the module is interpreted or not. - - --- Extract the filename, stringbuffer content and dynflags associed to a module --- --- XXX: Explain pre-conditions -getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) -getModuleSourceAndFlags mod = do - m <- getModSummary (moduleName mod) - case ml_hs_file $ ms_location m of - Nothing -> do dflags <- getDynFlags - liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod) - Just sourceFile -> do - source <- liftIO $ hGetStringBuffer sourceFile - return (sourceFile, source, ms_hspp_opts m) - - --- | Return module source as token stream, including comments. --- --- The module must be in the module graph and its source must be available. --- Throws a 'HscTypes.SourceError' on parse error. -getTokenStream :: GhcMonad m => Module -> m [Located Token] -getTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return ts - PFailed pst -> - do dflags <- getDynFlags - throwErrors (getErrorMessages pst dflags) - --- | Give even more information on the source than 'getTokenStream' --- This function allows reconstructing the source completely with --- 'showRichTokenStream'. -getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] -getRichTokenStream mod = do - (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 - case lexTokenStream source startLoc flags of - POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed pst -> - do dflags <- getDynFlags - throwErrors (getErrorMessages pst dflags) - --- | Given a source location and a StringBuffer corresponding to this --- location, return a rich token stream with the source associated to the --- tokens. -addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] - -> [(Located Token, String)] -addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(L span _) : ts) - = case span of - UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts - RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts - where - (newLoc, newBuf, str) = go "" loc buf - start = realSrcSpanStart s - end = realSrcSpanEnd s - go acc loc buf | loc < start = go acc nLoc nBuf - | start <= loc && loc < end = go (ch:acc) nLoc nBuf - | otherwise = (loc, buf, reverse acc) - where (ch, nBuf) = nextChar buf - nLoc = advanceSrcLoc loc ch - - --- | Take a rich token stream such as produced from 'getRichTokenStream' and --- return source code almost identical to the original code (except for --- insignificant whitespace.) -showRichTokenStream :: [(Located Token, String)] -> String -showRichTokenStream ts = go startLoc ts "" - where sourceFile = getFile $ map (getLoc . fst) ts - getFile [] = panic "showRichTokenStream: No source file found" - getFile (UnhelpfulSpan _ : xs) = getFile xs - getFile (RealSrcSpan s : _) = srcSpanFile s - startLoc = mkRealSrcLoc sourceFile 1 1 - go _ [] = id - go loc ((L span _, str):ts) - = case span of - UnhelpfulSpan _ -> go loc ts - RealSrcSpan s - | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) - . (str ++) - . go tokEnd ts - | otherwise -> ((replicate (tokLine - locLine) '\n') ++) - . ((replicate (tokCol - 1) ' ') ++) - . (str ++) - . go tokEnd ts - where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) - (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) - tokEnd = realSrcSpanEnd s - --- ----------------------------------------------------------------------------- --- Interactive evaluation - --- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the --- filesystem and package database to find the corresponding 'Module', --- using the algorithm that is used for an @import@ declaration. -findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - -- - case maybe_pkg of - Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m -> return m - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - _otherwise -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found loc m | moduleUnitId m /= this_pkg -> return m - | otherwise -> modNotLoadedError dflags m loc - err -> throwOneError $ noModError dflags noSrcSpan mod_name err - -modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a -modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ - text "module is not loaded:" <+> - quotes (ppr (moduleName m)) <+> - parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) - --- | Like 'findModule', but differs slightly when the module refers to --- a source file, and the file has not been loaded via 'load'. In --- this case, 'findModule' will throw an error (module not loaded), --- but 'lookupModule' will check to see whether the module can also be --- found in a package, and if so, that package 'Module' will be --- returned. If not, the usual module-not-found error will be thrown. --- -lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) -lookupModule mod_name Nothing = withSession $ \hsc_env -> do - home <- lookupLoadedHomeModule mod_name - case home of - Just m -> return m - Nothing -> liftIO $ do - res <- findExposedPackageModule hsc_env mod_name Nothing - case res of - Found _ m -> return m - err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err - -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) -lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) mod_name of - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing - --- | Check that a module is safe to import (according to Safe Haskell). --- --- We return True to indicate the import is safe and False otherwise --- although in the False case an error may be thrown first. -isModuleTrusted :: GhcMonad m => Module -> m Bool -isModuleTrusted m = withSession $ \hsc_env -> - liftIO $ hscCheckSafe hsc_env m noSrcSpan - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId) -moduleTrustReqs m = withSession $ \hsc_env -> - liftIO $ hscGetSafe hsc_env m noSrcSpan - --- | Set the monad GHCi lifts user statements into. --- --- Checks that a type (in string form) is an instance of the --- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, --- throws an error otherwise. -setGHCiMonad :: GhcMonad m => String -> m () -setGHCiMonad name = withSession $ \hsc_env -> do - ty <- liftIO $ hscIsGHCiMonad hsc_env name - modifySession $ \s -> - let ic = (hsc_IC s) { ic_monad = ty } - in s { hsc_IC = ic } - --- | Get the monad GHCi lifts user statements into. -getGHCiMonad :: GhcMonad m => m Name -getGHCiMonad = fmap (ic_monad . hsc_IC) getSession - -getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> - return $ GHC.Runtime.Eval.getHistorySpan hsc_env h - -obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a - -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id - - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = - withSession $ \hsc_env -> - liftIO $ hscTcRcLookupName hsc_env name - --- ----------------------------------------------------------------------------- --- Pure API - --- | A pure interface to the module parser. --- -parser :: String -- ^ Haskell module source text (full Unicode is supported) - -> DynFlags -- ^ the flags - -> FilePath -- ^ the filename (for source locations) - -> (WarningMessages, Either ErrorMessages (Located HsModule)) - -parser str dflags filename = - let - loc = mkRealSrcLoc (mkFastString filename) 1 1 - buf = stringToStringBuffer str - in - case unP Parser.parseModule (mkPState dflags buf loc) of - - PFailed pst -> - let (warns,errs) = getMessages pst dflags in - (warns, Left errs) - - POk pst rdr_module -> - let (warns,_) = getMessages pst dflags in - (warns, Right rdr_module) - --- ----------------------------------------------------------------------------- --- | Find the package environment (if one exists) --- --- We interpret the package environment as a set of package flags; to be --- specific, if we find a package environment file like --- --- > clear-package-db --- > global-package-db --- > package-db blah/package.conf.d --- > package-id id1 --- > package-id id2 --- --- we interpret this as --- --- > [ -hide-all-packages --- > , -clear-package-db --- > , -global-package-db --- > , -package-db blah/package.conf.d --- > , -package-id id1 --- > , -package-id id2 --- > ] --- --- There's also an older syntax alias for package-id, which is just an --- unadorned package id --- --- > id1 --- > id2 --- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do - mPkgEnv <- runMaybeT $ msum $ [ - getCmdLineArg >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , cmdLineError env - ] - , getEnvVar >>= \env -> msum [ - probeNullEnv env - , probeEnvFile env - , probeEnvName env - , envError env - ] - , notIfHideAllPackages >> msum [ - findLocalEnvFile >>= probeEnvFile - , probeEnvName defaultEnvName - ] - ] - case mPkgEnv of - Nothing -> - -- No environment found. Leave DynFlags unchanged. - return dflags - Just "-" -> do - -- Explicitly disabled environment file. Leave DynFlags unchanged. - return dflags - Just envfile -> do - content <- readFile envfile - compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) - let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags - - return dflags' - where - -- Loading environments (by name or by location) - - namedEnvPath :: String -> MaybeT IO FilePath - namedEnvPath name = do - appdir <- versionedAppDir dflags - return $ appdir </> "environments" </> name - - probeEnvName :: String -> MaybeT IO FilePath - probeEnvName name = probeEnvFile =<< namedEnvPath name - - probeEnvFile :: FilePath -> MaybeT IO FilePath - probeEnvFile path = do - guard =<< liftMaybeT (doesFileExist path) - return path - - probeNullEnv :: FilePath -> MaybeT IO FilePath - probeNullEnv "-" = return "-" - probeNullEnv _ = mzero - - -- Various ways to define which environment to use - - getCmdLineArg :: MaybeT IO String - getCmdLineArg = MaybeT $ return $ packageEnv dflags - - getEnvVar :: MaybeT IO String - getEnvVar = do - mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" - case mvar of - Right var -> return var - Left err -> if isDoesNotExistError err then mzero - else liftMaybeT $ throwIO err - - notIfHideAllPackages :: MaybeT IO () - notIfHideAllPackages = - guard (not (gopt Opt_HideAllPackages dflags)) - - defaultEnvName :: String - defaultEnvName = "default" - - -- e.g. .ghc.environment.x86_64-linux-7.6.3 - localEnvFileName :: FilePath - localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags - - -- Search for an env file, starting in the current dir and looking upwards. - -- Fail if we get to the users home dir or the filesystem root. That is, - -- we don't look for an env file in the user's home dir. The user-wide - -- env lives in ghc's versionedAppDir/environments/default - findLocalEnvFile :: MaybeT IO FilePath - findLocalEnvFile = do - curdir <- liftMaybeT getCurrentDirectory - homedir <- tryMaybeT getHomeDirectory - let probe dir | isDrive dir || dir == homedir - = mzero - probe dir = do - let file = dir </> localEnvFileName - exists <- liftMaybeT (doesFileExist file) - if exists - then return file - else probe (takeDirectory dir) - probe curdir - - -- Error reporting - - cmdLineError :: String -> MaybeT IO a - cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " ++ show env ++ " not found" - - envError :: String -> MaybeT IO a - envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ - "Package environment " - ++ show env - ++ " (specified in GHC_ENVIRONMENT) not found" diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs deleted file mode 100644 index 8bb2550d76..0000000000 --- a/compiler/main/GhcMake.hs +++ /dev/null @@ -1,2739 +0,0 @@ -{-# 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 GhcMake( - 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 DriverPhases -import DriverPipeline -import DynFlags -import ErrUtils -import Finder -import GhcMonad -import HeaderInfo -import HscTypes -import Module -import GHC.IfaceToCore ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import HscMain - -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 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 DriverPipeline.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 GhcMake 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/main/GhcMonad.hs b/compiler/main/GhcMonad.hs deleted file mode 100644 index 846744c439..0000000000 --- a/compiler/main/GhcMonad.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2010 --- --- The Session type and related functionality --- --- ----------------------------------------------------------------------------- - -module GhcMonad ( - -- * '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 HscTypes -import DynFlags -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/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs deleted file mode 100644 index 63c52d8e20..0000000000 --- a/compiler/main/GhcPlugins.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-} - --- | This module is not used by GHC itself. Rather, it exports all of --- the functions and types you are likely to need when writing a --- plugin for GHC. So authors of plugins can probably get away simply --- with saying "import GhcPlugins". --- --- Particularly interesting modules for plugin writers include --- "CoreSyn" and "CoreMonad". -module GhcPlugins( - module Plugins, - module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, - module CoreMonad, module CoreSyn, module Literal, module DataCon, - module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, - module Rules, module Annotations, - module DynFlags, module Packages, - module Module, module Type, module TyCon, module Coercion, - module TysWiredIn, module HscTypes, module BasicTypes, - module VarSet, module VarEnv, module NameSet, module NameEnv, - module UniqSet, module UniqFM, module FiniteMap, - module Util, module GHC.Serialized, module SrcLoc, module Outputable, - module UniqSupply, module Unique, module FastString, - - -- * Getting 'Name's - thNameToGhcName - ) where - --- Plugin stuff itself -import Plugins - --- Variable naming -import RdrName -import OccName hiding ( varName {- conflicts with Var.varName -} ) -import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) -import Var -import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) -import IdInfo - --- Core -import CoreMonad -import CoreSyn -import Literal -import DataCon -import CoreUtils -import MkCore -import CoreFVs -import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) - -- These names are also exported by Type - --- Core "extras" -import Rules -import Annotations - --- Pipeline-related stuff -import DynFlags -import Packages - --- Important GHC types -import Module -import Type hiding {- conflict with CoreSubst -} - ( substTy, extendTvSubst, extendTvSubstList, isInScope ) -import Coercion hiding {- conflict with CoreSubst -} - ( substCo ) -import TyCon -import TysWiredIn -import HscTypes -import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) - --- Collections and maps -import VarSet -import VarEnv -import NameSet -import NameEnv -import UniqSet -import UniqFM --- Conflicts with UniqFM: ---import LazyUniqFM -import FiniteMap - --- Common utilities -import Util -import GHC.Serialized -import SrcLoc -import Outputable -import UniqSupply -import Unique ( Unique, Uniquable(..) ) -import FastString -import Data.Maybe - -import GHC.Iface.Env ( lookupOrigIO ) -import GhcPrelude -import MonadUtils ( mapMaybeM ) -import GHC.ThToHs ( thRdrNameGuesses ) -import TcEnv ( lookupGlobal ) - -import qualified Language.Haskell.TH as TH - -{- This instance is defined outside CoreMonad.hs so that - CoreMonad does not depend on TcEnv -} -instance MonadThings CoreM where - lookupThing name = do { hsc_env <- getHscEnv - ; liftIO $ lookupGlobal hsc_env name } - -{- -************************************************************************ -* * - Template Haskell interoperability -* * -************************************************************************ --} - --- | Attempt to convert a Template Haskell name to one that GHC can --- understand. Original TH names such as those you get when you use --- the @'foo@ syntax will be translated to their equivalent GHC name --- exactly. Qualified or unqualified TH names will be dynamically bound --- to names in the module being compiled, if possible. Exact TH names --- will be bound to the name they represent, exactly. -thNameToGhcName :: TH.Name -> CoreM (Maybe Name) -thNameToGhcName th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) - -- Pick the first that works - -- E.g. reify (mkName "A") will pick the class A in preference - -- to the data constructor A - ; return (listToMaybe names) } - where - lookup rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = return $ if isExternalName n then Just n else Nothing - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { hsc_env <- getHscEnv - ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) } - | otherwise = return Nothing diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 4bd8a0993d..f7b2cd7fc5 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -23,7 +23,7 @@ module HeaderInfo ( getImports import GhcPrelude import GHC.Platform -import HscTypes +import GHC.Driver.Types import Parser ( parseHeader ) import Lexer import FastString @@ -32,7 +32,7 @@ import Module import PrelNames import StringBuffer import SrcLoc -import DynFlags +import GHC.Driver.Session import ErrUtils import Util import Outputable diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs deleted file mode 100644 index 064f96c33e..0000000000 --- a/compiler/main/Hooks.hs +++ /dev/null @@ -1,119 +0,0 @@ --- \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 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 DynFlags -import PipelineMonad -import HscTypes -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/main/Hooks.hs-boot b/compiler/main/Hooks.hs-boot deleted file mode 100644 index f0246ef941..0000000000 --- a/compiler/main/Hooks.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module Hooks where - -import GhcPrelude () - -data Hooks - -emptyHooks :: Hooks diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs deleted file mode 100644 index 879d8a05ec..0000000000 --- a/compiler/main/HscMain.hs +++ /dev/null @@ -1,1952 +0,0 @@ -{-# 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 "DriverPipeline". --- --- 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 HscMain - ( - -- * 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 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 CodeOutput -import InstEnv -import FamInstEnv -import Fingerprint ( Fingerprint ) -import Hooks -import TcEnv -import PrelNames -import Plugins -import GHC.Runtime.Loader ( initializePlugins ) - -import DynFlags -import ErrUtils - -import Outputable -import NameEnv -import HscStats ( ppSourceStats ) -import HscTypes -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 "HscMain.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 HscMain.hs and DriverPipeline.hs 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 HscMain: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 "HscMain.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 HscTypes --} - --- | 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 HscTypes - -- - 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/main/HscTypes.hs b/compiler/main/HscTypes.hs deleted file mode 100644 index 25b2f3e172..0000000000 --- a/compiler/main/HscTypes.hs +++ /dev/null @@ -1,3268 +0,0 @@ -{- -(c) The University of Glasgow, 2006 - -\section[HscTypes]{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 HscTypes ( - -- * 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 DriverPhases) - 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 Packages hiding ( Version(..) ) -import CmdLineParser -import DynFlags -import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) -import DriverPhases ( Phase, HscSource(..), hscSourceString - , isHsBootOrSig, isHsigFile ) -import qualified DriverPhases 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 (HscMain) 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 -> CmdLineParser.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 ('HscMain.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 diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs deleted file mode 100644 index 2817c99a5a..0000000000 --- a/compiler/main/Packages.hs +++ /dev/null @@ -1,2215 +0,0 @@ --- (c) The University of Glasgow, 2006 - -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} - --- | Package manipulation -module 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 DynFlags -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/main/Packages.hs-boot b/compiler/main/Packages.hs-boot deleted file mode 100644 index 3fd481021d..0000000000 --- a/compiler/main/Packages.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module Packages where -import GhcPrelude -import {-# SOURCE #-} DynFlags(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/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs deleted file mode 100644 index a3608ac4cd..0000000000 --- a/compiler/main/PipelineMonad.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE NamedFieldPuns #-} --- | The CompPipeline monad and associated ops --- --- Defined in separate module so that it can safely be imported from Hooks -module PipelineMonad ( - CompPipeline(..), evalP - , PhasePlus(..) - , PipeEnv(..), PipeState(..), PipelineOutput(..) - , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface - , pipeStateDynFlags, pipeStateModIface - ) where - -import GhcPrelude - -import MonadUtils -import Outputable -import DynFlags -import DriverPhases -import HscTypes -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/main/Plugins.hs b/compiler/main/Plugins.hs deleted file mode 100644 index cb367b4f67..0000000000 --- a/compiler/main/Plugins.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# 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 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 DynFlags -import HscTypes -import GhcMonad -import DriverPhases -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 - -- HscMain 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/main/Plugins.hs-boot b/compiler/main/Plugins.hs-boot deleted file mode 100644 index c90c6ebaf7..0000000000 --- a/compiler/main/Plugins.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ --- The plugins datatype is stored in DynFlags, so it needs to be --- exposed without importing all of its implementation. -module Plugins where - -import GhcPrelude () - -data Plugin - -data LoadedPlugin -data StaticPlugin diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 226986f7b5..11288618ef 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -25,7 +25,7 @@ import Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl ) import CoAxiom ( coAxiomTyCon ) -import HscTypes( tyThingParent_maybe ) +import GHC.Driver.Types( tyThingParent_maybe ) import GHC.Iface.Utils ( tyThingToIfaceDecl ) import FamInstEnv( FamInst(..), FamFlavor(..) ) import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index dfc54799d7..985e91e29c 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -119,7 +119,7 @@ Here is a running example: * If we are compiling for the byte-code interpreter, we instead explicitly add the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter process' SPT table using the addSptEntry interpreter message. This happens - in upsweep after we have compiled the module (see GhcMake.upsweep'). + in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). -} import GhcPrelude @@ -128,8 +128,8 @@ import GHC.Cmm.CLabel import CoreSyn import CoreUtils (collectMakeStaticArgs) import DataCon -import DynFlags -import HscTypes +import GHC.Driver.Session +import GHC.Driver.Types import Id import MkCore (mkStringExprFSWith) import Module diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index b3312b0dae..bbe889ba99 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -43,11 +43,11 @@ import GhcPrelude import GHC.Settings import Module -import Packages +import GHC.Driver.Packages import Outputable import ErrUtils import GHC.Platform -import DynFlags +import GHC.Driver.Session import Control.Monad.Trans.Except (runExceptT) import System.FilePath diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs index 13236933e6..9ff428f9ca 100644 --- a/compiler/main/SysTools/ExtraObj.hs +++ b/compiler/main/SysTools/ExtraObj.hs @@ -15,8 +15,8 @@ module SysTools.ExtraObj ( import AsmUtils import ErrUtils -import DynFlags -import Packages +import GHC.Driver.Session +import GHC.Driver.Packages import GHC.Platform import Outputable import SrcLoc ( noSrcSpan ) diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs index 93c2819528..b6b74406af 100644 --- a/compiler/main/SysTools/Info.hs +++ b/compiler/main/SysTools/Info.hs @@ -10,7 +10,7 @@ module SysTools.Info where import Exception import ErrUtils -import DynFlags +import GHC.Driver.Session import Outputable import Util diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs index c7255b6a93..8772e3eec1 100644 --- a/compiler/main/SysTools/Process.hs +++ b/compiler/main/SysTools/Process.hs @@ -12,7 +12,7 @@ module SysTools.Process where import Exception import ErrUtils -import DynFlags +import GHC.Driver.Session import FastString import Outputable import Panic diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs index d006a84b99..e4bbb32dc6 100644 --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -10,8 +10,8 @@ module SysTools.Tasks where import Exception import ErrUtils -import HscTypes -import DynFlags +import GHC.Driver.Types +import GHC.Driver.Session import Outputable import GHC.Platform import Util diff --git a/compiler/main/UpdateCafInfos.hs b/compiler/main/UpdateCafInfos.hs index c5e81150fe..600dc62207 100644 --- a/compiler/main/UpdateCafInfos.hs +++ b/compiler/main/UpdateCafInfos.hs @@ -7,7 +7,7 @@ module UpdateCafInfos import GhcPrelude import CoreSyn -import HscTypes +import GHC.Driver.Types import Id import IdInfo import InstEnv |