[Git][ghc/ghc][wip/romes/better-main-2] 4 commits: driver: Move DynFlags consistency fixes off Main
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Fri Mar 14 11:18:48 UTC 2025
Rodrigo Mesquita pushed to branch wip/romes/better-main-2 at Glasgow Haskell Compiler / GHC
Commits:
4ec85a8f by Rodrigo Mesquita at 2025-03-14T11:17:53+00:00
driver: Move DynFlags consistency fixes off Main
These consistency fixes found in Main.hs are required for the proper
functioning of the compiler and should live together with all remaining
fixes in `makeDynFlagsConsistent`.
This is especially relevant to GHC applications that shouldn't have to
copy/fix themselves possibly inconsistent DynFlags.
Additionally, outputs information when verbosity is high about these
consistency fixes that were previously quiet, adds information to the
Note on consistency of DynFlags, and improves one of the fixes that
incorrectly used `dynNow`.
- - - - -
93d2d600 by Rodrigo Mesquita at 2025-03-14T11:18:13+00:00
driver: Split Session functions out of Main
This commit moves out functions that help in creating and validating a
GHC session from Main into the ghc library where they can be used by
other GHC applications.
In particular:
- Move `Mode` types and functions (referring to the mode GHC is running
on) to `GHC.Driver.Session.Mode`
- Move `checkOptions` and aux functions, which validates GHC DynFlags
based on the mode, to `GHC.Driver.Session.Lint`
- Moves `initMulti` and aux functions, which initializes a multi-unit
session, into `GHC.Driver.Session.Units`.
- - - - -
cc3af792 by Rodrigo Mesquita at 2025-03-14T11:18:14+00:00
Add docs to obtainTermFromId
- - - - -
710ba89f by Rodrigo Mesquita at 2025-03-14T11:18:14+00:00
Move logic to find and set Breakpoint to GHC
Breakpoints are uniquely identified by a module and an index unique
within that module. `ModBreaks` of a Module contains arrays mapping from
this unique breakpoint index to information about each breakpoint. For
instance, `modBreaks_locs` stores the `SrcSpan` for each breakpoint.
To find a breakpoint using the line number you need to go through all
breakpoints in the array for a given module and look at the line and
column stored in the `SrcSpan`s. Similarly for columns and finding
breakpoints by name.
This logic previously lived within the `GHCi` application sources,
however, it is common to any GHC applications wanting to set
breakpoints, like the upcoming `ghc-debugger`.
This commit moves this logic for finding and setting breakpoints to the
GHC library so it can be used by both `ghci` and `ghc-debugger`.
- - - - -
16 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- + compiler/GHC/Driver/Session/Lint.hs
- + compiler/GHC/Driver/Session/Mode.hs
- + compiler/GHC/Driver/Session/Units.hs
- + compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- utils/check-exact/Parsers.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -918,7 +918,7 @@ parseDynamicFlags
-> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
parseDynamicFlags logger dflags cmdline = do
- (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
+ (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline
-- flags that have just been read are used by the logger when loading package
-- env (this is checked by T16318)
let logger1 = setLogFlags logger (initLogFlags dflags1)
@@ -1015,11 +1015,13 @@ normalise_hyp fp
checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags logger dflags = do
-- See Note [DynFlags consistency]
- let (dflags', warnings) = makeDynFlagsConsistent dflags
+ let (dflags', warnings, infoverb) = makeDynFlagsConsistent dflags
let diag_opts = initDiagOpts dflags
print_config = initPrintConfig dflags
liftIO $ printOrThrowDiagnostics logger print_config diag_opts
$ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings
+ when (logVerbAtLeast logger 3) $
+ mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb
return dflags'
checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
@@ -1846,7 +1848,11 @@ 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 :: GhcMonad m
+ => Int -- ^ How many times to recurse for subterms
+ -> Bool -- ^ Whether to force the expression
+ -> Id
+ -> m Term
obtainTermFromId bound force id = withSession $ \hsc_env ->
liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -100,8 +100,9 @@ doBackpack [src_filename] = do
dflags0 <- getDynFlags
let dflags1 = dflags0
let parser_opts1 = initParserOpts dflags1
+ logger0 <- getLogger
(p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 (supportedLanguagePragmas dflags1) src_filename
- (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
+ (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma logger0 dflags1 src_opts
modifySession (hscSetFlags dflags)
logger <- getLogger -- Get the logger after having set the session flags,
-- so that logger options are correctly set.
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1962,6 +1962,8 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
mgMapM enable_code_gen mg
where
defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)
+ -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`.
+ -- It would be good to consider how to make these checks more uniform and not duplicated.
enable_code_gen :: ModSummary -> IO ModSummary
enable_code_gen ms
| ModSummary
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -655,10 +655,11 @@ runUnlitPhase hsc_env input_fn output_fn = do
getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage))
getFileArgs hsc_env input_fn = do
let dflags0 = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
parser_opts = initParserOpts dflags0
(warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn
(dflags1, unhandled_flags, warns)
- <- parseDynamicFilePragma dflags0 src_opts
+ <- parseDynamicFilePragma logger dflags0 src_opts
checkProcessArgsResult unhandled_flags
return (dflags1, warns0, warns)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -247,6 +247,7 @@ import GHC.Driver.Plugins.External
import GHC.Settings.Config
import GHC.Core.Unfold
import GHC.Driver.CmdLine
+import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Constants (debugIsOn)
@@ -265,7 +266,7 @@ import GHC.Data.FastString
import GHC.Utils.TmpFs
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
-import GHC.Utils.Error (emptyDiagOpts)
+import GHC.Utils.Error (emptyDiagOpts, logInfo)
import GHC.Settings
import GHC.CmmToAsm.CFG.Weight
import GHC.Core.Opt.CallerCC
@@ -806,7 +807,7 @@ updOptLevel n = fst . updOptLevelChanged n
-- 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]
+parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
@@ -816,7 +817,7 @@ 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]
+parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String]
-> m (DynFlags, [Located String], Messages DriverMessage)
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
@@ -865,10 +866,11 @@ parseDynamicFlagsFull
:: forall m. MonadIO m
=> [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against
-> Bool -- ^ are the arguments from the command line?
+ -> Logger -- ^ logger
-> DynFlags -- ^ current dynamic flags
-> [Located String] -- ^ arguments to parse
-> m (DynFlags, [Located String], Messages DriverMessage)
-parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
+parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do
((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args
-- See Note [Handling errors when parsing command-line flags]
@@ -884,7 +886,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcExceptionIO (CmdLineError ("combination not supported: " ++
intercalate "/" (map wayDesc (Set.toAscList theWays))))
- let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2
+ let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2
-- Set timer stats & heap size
when (enableTimeStats dflags3) $ liftIO enableTimingStats
@@ -898,6 +900,9 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let diag_opts = initDiagOpts dflags3
warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns]
+ when (logVerbAtLeast logger 3) $
+ mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb
+
return (dflags3, leftover, warns)
-- | Check (and potentially disable) any extensions that aren't allowed
@@ -3491,12 +3496,35 @@ 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).
+
+Host ways vs Build ways mismatch
+--------------------------------
+Many consistency checks aim to fix the situation where the wanted build ways
+are not compatible with the ways the compiler is built in. This happens when
+using the interpreter, TH, and the runtime linker, where the compiler cannot
+load objects compiled for ways not matching its own.
+
+For instance, a profiled-dynamic object can only be loaded by a
+profiled-dynamic compiler (and not any other kind of compiler).
+
+This incompatibility is traditionally solved in either of two ways:
+
+(1) Force the "wanted" build ways to match the compiler ways exactly,
+ guaranteeing they match.
+
+(2) Force the use of the external interpreter. When interpreting is offloaded
+ to the external interpreter it no longer matters what are the host compiler ways.
+
+In the checks and fixes performed by `makeDynFlagsConsistent`, the choice
+between the two does not seem uniform. TODO: Make this choice more evident and uniform.
-}
-- | 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, [Warn])
+-- to report to the user, and a list of verbose info msgs.
+--
+-- See Note [DynFlags consistency]
+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc])
-- 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!
@@ -3587,13 +3615,41 @@ makeDynFlagsConsistent dflags
| LinkMergedObj <- ghcLink dflags
, Nothing <- outputFile dflags
- = pgmError "--output must be specified when using --merge-objs"
+ = pgmError "--output must be specified when using --merge-objs"
- | otherwise = (dflags, mempty)
+ -- When we do ghci, force using dyn ways if the target RTS linker
+ -- only supports dynamic code
+ | LinkInMemory <- ghcLink dflags
+ , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags
+ , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags)
+ = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $
+ -- See checkOptions, -fexternal-interpreter is
+ -- required when using --interactive with a non-standard
+ -- way (-prof, -static, or -dynamic).
+ setGeneralFlag' Opt_ExternalInterpreter $
+ addWay' WayDyn dflags
+
+ | ghcLink dflags `elem` [LinkInMemory, NoLink]
+ , not (gopt Opt_ExternalInterpreter dflags)
+ , targetWays_ dflags /= hostFullWays
+ = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $
+ let dflags_a = dflags { targetWays_ = hostFullWays }
+ dflags_b = foldl gopt_set dflags_a
+ $ concatMap (wayGeneralFlags platform)
+ hostFullWays
+ dflags_c = foldl gopt_unset dflags_b
+ $ concatMap (wayUnsetGeneralFlags platform)
+ hostFullWays
+ in dflags_c
+
+ | otherwise = (dflags, mempty, mempty)
where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
loop updated_dflags warning
= case makeDynFlagsConsistent updated_dflags of
- (dflags', ws) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws)
+ (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is)
+ loopNoWarn updated_dflags doc
+ = case makeDynFlagsConsistent updated_dflags of
+ (dflags', ws, is) -> (dflags', ws, L loc (text doc):is)
platform = targetPlatform dflags
arch = platformArch platform
os = platformOS platform
=====================================
compiler/GHC/Driver/Session/Lint.hs
=====================================
@@ -0,0 +1,124 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TupleSections #-}
+module GHC.Driver.Session.Lint (checkOptions) where
+
+import GHC.Driver.Backend
+import GHC.Driver.Phases
+import GHC.Driver.Session
+import GHC.Platform.Ways
+
+import GHC.Utils.Misc
+import GHC.Utils.Panic
+
+import GHC.Data.Maybe
+
+import System.IO
+import Control.Monad
+import qualified Data.Set as Set
+import Prelude
+
+import GHC.Driver.Session.Mode
+
+-- -----------------------------------------------------------------------------
+-- Option sanity checks
+
+-- | Ensure sanity of options.
+--
+-- Throws 'UsageError' or 'CmdLineError' if not.
+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()
+ -- Final sanity checking before kicking off a compilation (pipeline).
+checkOptions mode dflags srcs objs units = do
+ -- Complain about any unknown flags
+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
+
+ when (not (Set.null (rtsWays (ways dflags)))
+ && isInterpretiveMode mode) $
+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
+
+ -- -prof and --interactive are not a good combination
+ when ((fullWays (ways dflags) /= hostFullWays)
+ && isInterpretiveMode mode
+ && not (gopt Opt_ExternalInterpreter dflags)) $
+ do throwGhcException (UsageError
+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
+ -- -ohi sanity check
+ if (isJust (outputHi dflags) &&
+ (isCompManagerMode mode || srcs `lengthExceeds` 1))
+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
+ else do
+
+ if (isJust (dynOutputHi dflags) &&
+ (isCompManagerMode mode || srcs `lengthExceeds` 1))
+ then throwGhcException (UsageError "-dynohi can only be used when compiling a single source file")
+ else do
+
+ -- -o sanity checking
+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
+ && not (isLinkMode mode))
+ then throwGhcException (UsageError "can't apply -o to multiple source files")
+ else do
+
+ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
+
+ when (not_linking && not (null objs)) $
+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
+
+ -- Check that there are some input files
+ -- (except in the interactive case)
+ if null srcs && (null objs || not_linking) && needsInputsMode mode && null units
+ then throwGhcException (UsageError "no input files" )
+ else do
+
+ case mode of
+ StopBefore StopC | not (backendGeneratesHc (backend dflags))
+ -> throwGhcException $ UsageError $
+ "the option -C is only available with an unregisterised GHC"
+ StopBefore StopAs | ghcLink dflags == NoLink
+ -> throwGhcException $ UsageError $
+ "the options -S and -fno-code are incompatible. Please omit -S"
+
+ _ -> return ()
+
+ -- Verify that output files point somewhere sensible.
+ verifyOutputFiles dflags
+
+-- Compiler output options
+
+-- Called to verify that the output files point somewhere valid.
+--
+-- The assumption is that the directory portion of these output
+-- options will have to exist by the time 'verifyOutputFiles'
+-- is invoked.
+--
+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
+-- they don't exist, so don't check for those here (#2278).
+verifyOutputFiles :: DynFlags -> IO ()
+verifyOutputFiles dflags = do
+ let ofile = outputFile dflags
+ when (isJust ofile) $ do
+ let fn = fromJust ofile
+ flg <- doesDirNameExist fn
+ when (not flg) (nonExistentDir "-o" fn)
+ let ohi = outputHi dflags
+ when (isJust ohi) $ do
+ let hi = fromJust ohi
+ flg <- doesDirNameExist hi
+ when (not flg) (nonExistentDir "-ohi" hi)
+ where
+ nonExistentDir flg dir =
+ throwGhcException (CmdLineError ("error: directory portion of " ++
+ show dir ++ " does not exist (used with " ++
+ show flg ++ " option.)"))
+
+-- | Utility for reporting unknown flag error
+unknownFlagsErr :: [String] -> a
+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
+ where
+ oneError f =
+ "unrecognised flag: " ++ f ++ "\n" ++
+ (case flagSuggestions (nubSort allNonDeprecatedFlags) f of
+ [] -> ""
+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
=====================================
compiler/GHC/Driver/Session/Mode.hs
=====================================
@@ -0,0 +1,327 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TupleSections #-}
+module GHC.Driver.Session.Mode where
+
+import GHC.Driver.CmdLine
+import GHC.Driver.Phases
+import GHC.Driver.Session
+import GHC.Unit.Module ( ModuleName, mkModuleName )
+
+import GHC.Types.SrcLoc
+
+import GHC.Utils.Panic
+
+import GHC.Data.Maybe
+
+-- Standard Haskell libraries
+import System.IO
+import Control.Monad
+import Data.Char
+import Prelude
+
+-----------------------------------------------------------------------------
+-- GHC modes of operation
+
+type Mode = Either PreStartupMode PostStartupMode
+type PostStartupMode = Either PreLoadMode PostLoadMode
+
+data PreStartupMode
+ = ShowVersion -- ghc -V/--version
+ | ShowNumVersion -- ghc --numeric-version
+ | ShowSupportedExtensions -- ghc --supported-extensions
+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options
+
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
+showVersionMode = mkPreStartupMode ShowVersion
+showNumVersionMode = mkPreStartupMode ShowNumVersion
+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
+showOptionsMode = mkPreStartupMode (ShowOptions False)
+
+mkPreStartupMode :: PreStartupMode -> Mode
+mkPreStartupMode = Left
+
+isShowVersionMode :: Mode -> Bool
+isShowVersionMode (Left ShowVersion) = True
+isShowVersionMode _ = False
+
+isShowNumVersionMode :: Mode -> Bool
+isShowNumVersionMode (Left ShowNumVersion) = True
+isShowNumVersionMode _ = False
+
+data PreLoadMode
+ = ShowGhcUsage -- ghc -?
+ | ShowGhciUsage -- ghci -?
+ | ShowInfo -- ghc --info
+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
+
+showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
+showGhcUsageMode = mkPreLoadMode ShowGhcUsage
+showGhciUsageMode = mkPreLoadMode ShowGhciUsage
+showInfoMode = mkPreLoadMode ShowInfo
+
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+ $ lookup k (compilerInfo dflags)
+
+mkPreLoadMode :: PreLoadMode -> Mode
+mkPreLoadMode = Right . Left
+
+isShowGhcUsageMode :: Mode -> Bool
+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
+isShowGhcUsageMode _ = False
+
+isShowGhciUsageMode :: Mode -> Bool
+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
+isShowGhciUsageMode _ = False
+
+data PostLoadMode
+ = ShowInterface FilePath -- ghc --show-iface
+ | DoMkDependHS -- ghc -M
+ | StopBefore StopPhase -- ghc -E | -C | -S
+ -- StopBefore StopLn is the default
+ | DoMake -- ghc --make
+ | DoBackpack -- ghc --backpack foo.bkp
+ | DoInteractive -- ghc --interactive
+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+ | DoRun -- ghc --run
+ | DoAbiHash -- ghc --abi-hash
+ | ShowPackages -- ghc --show-packages
+ | DoFrontend ModuleName -- ghc --frontend Plugin.Module
+
+doMkDependHSMode, doMakeMode, doInteractiveMode, doRunMode,
+ doAbiHashMode, showUnitsMode :: Mode
+doMkDependHSMode = mkPostLoadMode DoMkDependHS
+doMakeMode = mkPostLoadMode DoMake
+doInteractiveMode = mkPostLoadMode DoInteractive
+doRunMode = mkPostLoadMode DoRun
+doAbiHashMode = mkPostLoadMode DoAbiHash
+showUnitsMode = mkPostLoadMode ShowPackages
+
+showInterfaceMode :: FilePath -> Mode
+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+
+stopBeforeMode :: StopPhase -> Mode
+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
+
+doEvalMode :: String -> Mode
+doEvalMode str = mkPostLoadMode (DoEval [str])
+
+doFrontendMode :: String -> Mode
+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
+
+doBackpackMode :: Mode
+doBackpackMode = mkPostLoadMode DoBackpack
+
+mkPostLoadMode :: PostLoadMode -> Mode
+mkPostLoadMode = Right . Right
+
+isDoInteractiveMode :: Mode -> Bool
+isDoInteractiveMode (Right (Right DoInteractive)) = True
+isDoInteractiveMode _ = False
+
+isStopLnMode :: Mode -> Bool
+isStopLnMode (Right (Right (StopBefore NoStop))) = True
+isStopLnMode _ = False
+
+isDoMakeMode :: Mode -> Bool
+isDoMakeMode (Right (Right DoMake)) = True
+isDoMakeMode _ = False
+
+isDoEvalMode :: Mode -> Bool
+isDoEvalMode (Right (Right (DoEval _))) = True
+isDoEvalMode _ = False
+
+#if defined(HAVE_INTERNAL_INTERPRETER)
+isInteractiveMode :: PostLoadMode -> Bool
+isInteractiveMode DoInteractive = True
+isInteractiveMode _ = False
+#endif
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: PostLoadMode -> Bool
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _) = True
+isInterpretiveMode _ = False
+
+needsInputsMode :: PostLoadMode -> Bool
+needsInputsMode DoMkDependHS = True
+needsInputsMode (StopBefore _) = True
+needsInputsMode DoMake = True
+needsInputsMode _ = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: PostLoadMode -> Bool
+isLinkMode (StopBefore NoStop) = True
+isLinkMode DoMake = True
+isLinkMode DoRun = True
+isLinkMode DoInteractive = True
+isLinkMode (DoEval _) = True
+isLinkMode _ = False
+
+isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoRun = True
+isCompManagerMode DoMake = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _) = True
+isCompManagerMode _ = False
+
+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [Located String]
+ -> IO (Mode, [String],
+ [Located String],
+ [Warn])
+parseModeFlags args = do
+ ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <-
+ processCmdLineP mode_flags (Nothing, [], [], []) args
+ let mode = case mModeFlag of
+ Nothing -> doMakeMode
+ Just (m, _) -> m
+
+ -- See Note [Handling errors when parsing command-line flags]
+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
+ map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
+
+ return (mode, units, flags' ++ leftover, warns)
+
+type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String])
+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+ -- so we collect the new ones and return them.
+
+mode_flags :: [Flag ModeM]
+mode_flags =
+ [ ------- help / version ----------------------------------------------
+ defFlag "?" (PassFlag (setMode showGhcUsageMode))
+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))
+ , defFlag "V" (PassFlag (setMode showVersionMode))
+ , defFlag "-version" (PassFlag (setMode showVersionMode))
+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
+ , defFlag "-info" (PassFlag (setMode showInfoMode))
+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))
+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+ , defFlag "-show-packages" (PassFlag (setMode showUnitsMode))
+ ] ++
+ [ defFlag k' (PassFlag (setMode (printSetting k)))
+ | k <- ["Project version",
+ "Project Git commit id",
+ "Booter version",
+ "Stage",
+ "Build platform",
+ "Host platform",
+ "Target platform",
+ "Have interpreter",
+ "Object splitting supported",
+ "Have native code generator",
+ "Support SMP",
+ "Unregisterised",
+ "Tables next to code",
+ "RTS ways",
+ "Leading underscore",
+ "Debug on",
+ "LibDir",
+ "Global Package DB",
+ "C compiler flags",
+ "C compiler link flags"
+ ],
+ let k' = "-print-" ++ map (replaceSpace . toLower) k
+ replaceSpace ' ' = '-'
+ replaceSpace c = c
+ ] ++
+ ------- interfaces ----------------------------------------------------
+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
+ "--show-iface"))
+
+ ------- primary modes ------------------------------------------------
+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode NoStop) f
+ addFlag "-no-link" f))
+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))
+ , defFlag "E" (PassFlag (setMode (stopBeforeMode StopPreprocess )))
+ , defFlag "C" (PassFlag (setMode (stopBeforeMode StopC)))
+ , defFlag "S" (PassFlag (setMode (stopBeforeMode StopAs)))
+ , defFlag "-run" (PassFlag (setMode doRunMode))
+ , defFlag "-make" (PassFlag (setMode doMakeMode))
+ , defFlag "unit" (SepArg (\s -> addUnit s "-unit"))
+ , defFlag "-backpack" (PassFlag (setMode doBackpackMode))
+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
+ , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))
+ ]
+
+addUnit :: String -> String -> EwM ModeM ()
+addUnit unit_str _arg = liftEwM $ do
+ (mModeFlag, units, errs, flags') <- getCmdLineState
+ putCmdLineState (mModeFlag, unit_str:units, errs, flags')
+
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
+ (mModeFlag, units, errs, flags') <- getCmdLineState
+ let (modeFlag', errs') =
+ case mModeFlag of
+ Nothing -> ((newMode, newFlag), errs)
+ Just (oldMode, oldFlag) ->
+ case (oldMode, newMode) of
+ -- -c/--make are allowed together, and mean --make -no-link
+ _ | isStopLnMode oldMode && isDoMakeMode newMode
+ || isStopLnMode newMode && isDoMakeMode oldMode ->
+ ((doMakeMode, "--make"), [])
+
+ -- If we have both --help and --interactive then we
+ -- want showGhciUsage
+ _ | isShowGhcUsageMode oldMode &&
+ isDoInteractiveMode newMode ->
+ ((showGhciUsageMode, oldFlag), [])
+ | isShowGhcUsageMode newMode &&
+ isDoInteractiveMode oldMode ->
+ ((showGhciUsageMode, newFlag), [])
+
+ -- If we have both -e and --interactive then -e always wins
+ _ | isDoEvalMode oldMode &&
+ isDoInteractiveMode newMode ->
+ ((oldMode, oldFlag), [])
+ | isDoEvalMode newMode &&
+ isDoInteractiveMode oldMode ->
+ ((newMode, newFlag), [])
+
+ -- Otherwise, --help/--version/--numeric-version always win
+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
+ | isDominantFlag newMode -> ((newMode, newFlag), [])
+ -- We need to accumulate eval flags like "-e foo -e bar"
+ (Right (Right (DoEval esOld)),
+ Right (Right (DoEval [eNew]))) ->
+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),
+ errs)
+ -- Saying e.g. --interactive --interactive is OK
+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
+
+ -- --interactive and --show-options are used together
+ (Right (Right DoInteractive), Left (ShowOptions _)) ->
+ ((Left (ShowOptions True),
+ "--interactive --show-options"), errs)
+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->
+ ((Left (ShowOptions True),
+ "--show-options --interactive"), errs)
+ -- Otherwise, complain
+ _ -> let err = flagMismatchErr oldFlag newFlag
+ in ((oldMode, oldFlag), err : errs)
+ putCmdLineState (Just modeFlag', units, errs', flags')
+ where isDominantFlag f = isShowGhcUsageMode f ||
+ isShowGhciUsageMode f ||
+ isShowVersionMode f ||
+ isShowNumVersionMode f
+
+flagMismatchErr :: String -> String -> String
+flagMismatchErr oldFlag newFlag
+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
+
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
+ (m, units, e, flags') <- getCmdLineState
+ putCmdLineState (m, units, e, mkGeneralLocated loc s : flags')
+ where loc = "addFlag by " ++ flag ++ " on the commandline"
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -0,0 +1,226 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TupleSections #-}
+module GHC.Driver.Session.Units (initMulti) where
+
+-- The official GHC API
+import qualified GHC
+import GHC (parseTargetFiles, Ghc, GhcMonad(..))
+
+import GHC.Driver.Env
+import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
+import GHC.Driver.Phases
+import GHC.Driver.Session
+import GHC.Driver.Ppr
+import GHC.Driver.Pipeline ( oneShot, compileFile )
+import GHC.Driver.Config.Diagnostic
+
+import GHC.Unit.Env
+import GHC.Unit (UnitId)
+import GHC.Unit.Home.PackageTable
+import qualified GHC.Unit.Home.Graph as HUG
+import GHC.Unit.State ( emptyUnitState )
+import qualified GHC.Unit.State as State
+
+import GHC.Types.SrcLoc
+import GHC.Types.SourceError
+
+import GHC.Utils.Misc
+import GHC.Utils.Panic
+import GHC.Utils.Outputable as Outputable
+import GHC.Utils.Monad ( liftIO, mapMaybeM )
+import GHC.Data.Maybe
+
+import System.IO
+import System.Exit
+import System.FilePath
+import Control.Monad
+import Data.List ( partition, (\\) )
+import qualified Data.Set as Set
+import Prelude
+import GHC.ResponseFile (expandResponse)
+import Data.Bifunctor
+import GHC.Data.Graph.Directed
+import qualified Data.List.NonEmpty as NE
+
+import GHC.Driver.Session.Mode
+import GHC.Driver.Session.Lint
+
+-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
+removeRTS :: [String] -> [String]
+removeRTS ("+RTS" : xs) =
+ case dropWhile (/= "-RTS") xs of
+ [] -> []
+ (_ : ys) -> removeRTS ys
+removeRTS (y:ys) = y : removeRTS ys
+removeRTS [] = []
+
+initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)])
+initMulti unitArgsFiles = do
+ hsc_env <- GHC.getSession
+ let logger = hsc_logger hsc_env
+ initial_dflags <- GHC.getSessionDynFlags
+
+ dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do
+ when (verbosity initial_dflags > 2) (liftIO $ print f)
+ args <- liftIO $ expandResponse [f]
+ (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args))
+ handleSourceError (\e -> do
+ GHC.printException e
+ liftIO $ exitWith (ExitFailure 1)) $ do
+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)
+
+ let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)
+ dflags4 = offsetDynFlags dflags3
+
+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
+
+ -- This is dubious as the whole unit environment won't be set-up correctly, but
+ -- that doesn't matter for what we use it for (linking and oneShot)
+ let dubious_hsc_env = hscSetFlags dflags4 hsc_env
+ -- if we have no haskell sources from which to do a dependency
+ -- analysis, then just do one-shot compilation and/or linking.
+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+ -- we expect.
+ if (null hs_srcs)
+ then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])
+ else do
+
+ o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)
+ non_hs_srcs
+ let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files
+ ++ ldInputs dflags4 }
+
+ liftIO $ checkOptions DoMake dflags5 srcs objs []
+
+ pure (dflags5, hs_srcs)
+
+ let
+ unitDflags = NE.map fst dynFlagsAndSrcs
+ srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs
+ (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))
+
+ checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))
+
+ (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags
+ let home_units = HUG.allUnits initial_home_graph
+
+ home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
+ hue_flags = homeUnitEnv_dflags homeUnitEnv
+ dflags = homeUnitEnv_dflags homeUnitEnv
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+
+ updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
+ emptyHpt <- liftIO $ emptyHomePackageTable
+ pure $ HomeUnitEnv
+ { homeUnitEnv_units = unit_state
+ , homeUnitEnv_unit_dbs = Just dbs
+ , homeUnitEnv_dflags = updated_dflags
+ , homeUnitEnv_hpt = emptyHpt
+ , homeUnitEnv_home_unit = Just home_unit
+ }
+
+ checkUnitCycles initial_dflags home_unit_graph
+
+ let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph
+ unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+
+ GHC.setSession final_hsc_env
+
+ -- if we have no haskell sources from which to do a dependency
+ -- analysis, then just do one-shot compilation and/or linking.
+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+ -- we expect.
+ if (null hs_srcs)
+ then do
+ liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."
+ liftIO $ exitWith (ExitFailure 1)
+ else do
+
+{-
+ o_files <- liftIO $ mapMaybeM
+ (\(src, uid, mphase) ->
+ compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)
+ )
+ (concat non_hs_srcs)
+ -}
+
+ -- MP: This should probably modify dflags for each unit?
+ --let dflags' = dflags { ldInputs = map (FileOption "") o_files
+ -- ++ ldInputs dflags }
+ return $ concat hs_srcs
+
+checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc ()
+checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
+ where
+
+ processSCCs [] = return ()
+ processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs
+ processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
+
+
+ cycle_err uids =
+ hang (text "Units form a dependency cycle:")
+ 2
+ (one_err uids)
+
+ one_err uids = vcat $
+ (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)
+ ++ [text "-" <+> ppr final]
+ where
+ start = init uids
+ final = last uids
+
+-- | Check that we don't have multiple units with the same UnitId.
+checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
+checkDuplicateUnits dflags flags =
+ unless (null duplicate_ids)
+ (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)
+
+ where
+ uids = map (second homeUnitId_) flags
+ deduplicated_uids = ordNubOn snd uids
+ duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)
+
+ duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids
+
+ one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp
+
+ multi_err =
+ hang (text "Multiple units with the same unit-id:")
+ 2
+ (vcat (map one_err duplicate_flags))
+
+
+offsetDynFlags :: DynFlags -> DynFlags
+offsetDynFlags dflags =
+ dflags { hiDir = c hiDir
+ , objectDir = c objectDir
+ , stubDir = c stubDir
+ , hieDir = c hieDir
+ , dumpDir = c dumpDir }
+
+ where
+ c f = augment_maybe (f dflags)
+
+ augment_maybe Nothing = Nothing
+ augment_maybe (Just f) = Just (augment f)
+ augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f
+ | otherwise = f
+
+
+createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
+createUnitEnvFromFlags unitDflags = do
+ unitEnvList <- forM unitDflags $ \dflags -> do
+ emptyHpt <- emptyHomePackageTable
+ let newInternalUnitEnv =
+ HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing
+ return (homeUnitId_ dflags, newInternalUnitEnv)
+ let activeUnit = fst $ NE.head unitEnvList
+ return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)
+
+
=====================================
compiler/GHC/Runtime/Debugger/Breakpoints.hs
=====================================
@@ -0,0 +1,106 @@
+-- | GHC API debugger module for finding and setting breakpoints.
+--
+-- This module is user facing and is at least used by `GHCi` and `ghc-debugger`
+-- to find and set breakpoints.
+module GHC.Runtime.Debugger.Breakpoints where
+
+import GHC.Prelude
+import GHC.Types.SrcLoc
+import qualified GHC.Data.Strict as Strict
+import qualified Data.Semigroup as S
+import Data.List
+import Data.Maybe
+import Data.Function
+import Control.Monad
+import GHC
+import Data.Array
+
+--------------------------------------------------------------------------------
+-- Finding breakpoints
+--------------------------------------------------------------------------------
+
+-- | Find a breakpoint given a Module's 'TickArray' and the line number.
+--
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+-- - the leftmost complete subexpression on the specified line, or
+-- - the leftmost subexpression starting on the specified line, or
+-- - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int {-^ Line number -} -> TickArray -> Maybe (BreakIndex, RealSrcSpan)
+findBreakByLine line arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`
+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
+ listToMaybe (sortBy (flip compare `on` snd) ticks)
+ where
+ ticks = arr ! line
+
+ starts_here = [ (ix,pan) | (ix, pan) <- ticks,
+ GHC.srcSpanStartLine pan == line ]
+
+ (comp, incomp) = partition ends_here starts_here
+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
+
+-- | The aim of this function is to find the breakpoints for all the RHSs of
+-- the equations corresponding to a binding. So we find all breakpoints
+-- for
+-- (a) this binder only (it maybe a top-level or a nested declaration)
+-- (b) that do not have an enclosing breakpoint
+findBreakForBind :: String {-^ Name of bind to break at -} -> GHC.ModBreaks -> [(BreakIndex, RealSrcSpan)]
+findBreakForBind str_name modbreaks = filter (not . enclosed) ticks
+ where
+ ticks = [ (index, span)
+ | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),
+ str_name == intercalate "." decls,
+ RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]
+ enclosed (_,sp0) = any subspan ticks
+ where subspan (_,sp) = sp /= sp0 &&
+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&
+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp
+
+-- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate.
+findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakIndex, RealSrcSpan)
+findBreakByCoord (line, col) arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy (flip compare `on` snd) contains ++
+ sortBy (compare `on` snd) after_here)
+ where
+ ticks = arr ! line
+
+ -- the ticks that span this coordinate
+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ]
+
+ after_here = [ tick | tick@(_,pan) <- ticks,
+ GHC.srcSpanStartLine pan == line,
+ GHC.srcSpanStartCol pan >= col ]
+
+leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
+leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd
+
+--------------------------------------------------------------------------------
+-- Mapping line numbers to ticks
+--------------------------------------------------------------------------------
+
+-- | Maps line numbers to the breakpoint ticks existing at that line for a module.
+type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
+
+-- | Construct the 'TickArray' for the given module.
+makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray)
+makeModuleLineMap m = do
+ mi <- GHC.getModuleInfo m
+ return $
+ mkTickArray . assocs . GHC.modBreaks_locs . GHC.modInfoModBreaks <$> mi
+ where
+ mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray
+ mkTickArray ticks
+ = accumArray (flip (:)) [] (1, max_line)
+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]
+ where
+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
+
+
+
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -1266,7 +1266,7 @@ dynCompileExpr expr = do
return (unsafeCoerce hval :: Dynamic)
-----------------------------------------------------------------------------
--- show a module and it's source/object filenames
+-- show a module and its source/object filenames
showModule :: GhcMonad m => ModSummary -> m String
showModule mod_summary =
=====================================
compiler/GHC/Runtime/Eval/Types.hs
=====================================
@@ -76,7 +76,8 @@ breakHere step break_span = case step of
data ExecResult
- -- | Execution is complete
+ -- | Execution is complete with either an exception or the list of
+ -- user-visible names that were brought into scope.
= ExecComplete
{ execResult :: Either SomeException [Name]
, execAllocation :: Word64
=====================================
compiler/ghc.cabal.in
=====================================
@@ -536,6 +536,9 @@ Library
GHC.Driver.Plugins.External
GHC.Driver.Ppr
GHC.Driver.Session
+ GHC.Driver.Session.Lint
+ GHC.Driver.Session.Mode
+ GHC.Driver.Session.Units
GHC.Hs
GHC.Hs.Basic
GHC.Hs.Binds
@@ -694,6 +697,7 @@ Library
GHC.Rename.Utils
GHC.Runtime.Context
GHC.Runtime.Debugger
+ GHC.Runtime.Debugger.Breakpoints
GHC.Runtime.Eval
GHC.Runtime.Eval.Types
GHC.Runtime.Heap.Inspect
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -40,6 +40,7 @@ import GHCi.Leak
import GHCi.UI.Print
import GHC.Runtime.Debugger
+import GHC.Runtime.Debugger.Breakpoints
import GHC.Runtime.Eval (mkTopLevEnv)
-- The GHC interface
@@ -3148,7 +3149,7 @@ newDynFlags interactive_only minus_opts = do
logger <- getLogger
idflags0 <- GHC.getInteractiveDynFlags
- (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts
+ (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts
liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)
when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)
@@ -3161,7 +3162,7 @@ newDynFlags interactive_only minus_opts = do
dflags0 <- getDynFlags
when (not interactive_only) $ do
- (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts
+ (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine logger dflags0 lopts
must_reload <- GHC.setProgramDynFlags dflags1
-- if the package flags changed, reset the context and link
@@ -3853,9 +3854,6 @@ enclosingTickSpan md (RealSrcSpan src _) = do
return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans
where
-leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
-leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd
-
traceCmd :: GhciMonad m => String -> m ()
traceCmd arg
= withSandboxOnly ":trace" $ tr arg
@@ -4089,7 +4087,7 @@ breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()
breakByModuleLine md line args
| [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
| [col] <- args, all isDigit col =
- findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
+ findBreakAndSet md $ maybeToList . findBreakByCoord (line, read col)
| otherwise = breakSyntax
-- Set a breakpoint for an identifier
@@ -4113,7 +4111,7 @@ breakById inp = do
let modBreaks = case mb_mod_info of
(Just mod_info) -> GHC.modInfoModBreaks mod_info
Nothing -> emptyModBreaks
- findBreakAndSet (fromJust mb_mod) $ findBreakForBind fun_str modBreaks
+ findBreakAndSet (fromJust mb_mod) $ \_ -> findBreakForBind fun_str modBreaks
where
-- Try to lookup the module for an identifier that is in scope.
-- `parseName` throws an exception, if the identifier is not in scope
@@ -4181,68 +4179,6 @@ findBreakAndSet md lookupTickTree = do
then text " was already set at " <> ppr pan
else text " activated at " <> ppr pan
--- When a line number is specified, the current policy for choosing
--- the best breakpoint is this:
--- - the leftmost complete subexpression on the specified line, or
--- - the leftmost subexpression starting on the specified line, or
--- - the rightmost subexpression enclosing the specified line
---
-findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
-findBreakByLine line arr
- | not (inRange (bounds arr) line) = Nothing
- | otherwise =
- listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`
- listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
- listToMaybe (sortBy (flip compare `on` snd) ticks)
- where
- ticks = arr ! line
-
- starts_here = [ (ix,pan) | (ix, pan) <- ticks,
- GHC.srcSpanStartLine pan == line ]
-
- (comp, incomp) = partition ends_here starts_here
- where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
-
--- The aim is to find the breakpoints for all the RHSs of the
--- equations corresponding to a binding. So we find all breakpoints
--- for
--- (a) this binder only (it maybe a top-level or a nested declaration)
--- (b) that do not have an enclosing breakpoint
-findBreakForBind :: String -> GHC.ModBreaks -> TickArray
- -> [(BreakIndex,RealSrcSpan)]
-findBreakForBind str_name modbreaks _ = filter (not . enclosed) ticks
- where
- ticks = [ (index, span)
- | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),
- str_name == declPath decls,
- RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]
- enclosed (_,sp0) = any subspan ticks
- where subspan (_,sp) = sp /= sp0 &&
- realSrcSpanStart sp <= realSrcSpanStart sp0 &&
- realSrcSpanEnd sp0 <= realSrcSpanEnd sp
-
-findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
- -> Maybe (BreakIndex,RealSrcSpan)
-findBreakByCoord mb_file (line, col) arr
- | not (inRange (bounds arr) line) = Nothing
- | otherwise =
- listToMaybe (sortBy (flip compare `on` snd) contains ++
- sortBy (compare `on` snd) after_here)
- where
- ticks = arr ! line
-
- -- the ticks that span this coordinate
- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col),
- is_correct_file pan ]
-
- is_correct_file pan
- | Just f <- mb_file = GHC.srcSpanFile pan == f
- | otherwise = True
-
- after_here = [ tick | tick@(_,pan) <- ticks,
- GHC.srcSpanStartLine pan == line,
- GHC.srcSpanStartCol pan >= col ]
-
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
-- In particular, on Windows and when running the testsuite (which sets
@@ -4327,7 +4263,7 @@ list2 [arg] = do
RealSrcLoc l _ ->
do tickArray <- assert (isExternalName name) $
getTickArray (GHC.nameModule name)
- let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+ let mb_span = findBreakByCoord
(GHC.srcLocLine l, GHC.srcLocCol l)
tickArray
case mb_span of
@@ -4435,22 +4371,13 @@ getTickArray modl = do
case lookupModuleEnv arrmap modl of
Just arr -> return arr
Nothing -> do
- (ticks, _) <- getModBreak modl
- let arr = mkTickArray (assocs ticks)
+ arr <- fromMaybe (panic "getTickArray") <$> makeModuleLineMap modl
setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
return arr
discardTickArrays :: GhciMonad m => m ()
discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
-mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
-mkTickArray ticks
- = accumArray (flip (:)) [] (1, max_line)
- [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]
- where
- max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]
- srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
-
-- don't reset the counter back to zero?
discardActiveBreakPoints :: GhciMonad m => m ()
discardActiveBreakPoints = do
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -56,10 +56,10 @@ import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
import GHC.Hs.Utils
import GHC.Utils.Misc
import GHC.Utils.Logger
+import GHC.Runtime.Debugger.Breakpoints
import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)
import Numeric
-import Data.Array
import Data.IORef
import Data.Time
import System.Environment
@@ -164,8 +164,6 @@ data GHCiState = GHCiState
ifaceCache :: ModIfaceCache
}
-type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
-
-- | A GHCi command
data Command
= Command
=====================================
ghc/Main.hs
=====================================
@@ -35,7 +35,6 @@ import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Diagnostic
import GHC.Platform
-import GHC.Platform.Ways
import GHC.Platform.Host
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -44,15 +43,10 @@ import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings
import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins )
-import GHC.Unit.Env
-import GHC.Unit (UnitId)
-import GHC.Unit.Home.PackageTable
-import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Module ( ModuleName, mkModuleName )
import GHC.Unit.Module.ModIface
-import GHC.Unit.State ( pprUnits, pprUnitsSimple, emptyUnitState )
+import GHC.Unit.State ( pprUnits, pprUnitsSimple )
import GHC.Unit.Finder ( findImportedModule, FindResult(..) )
-import qualified GHC.Unit.State as State
import GHC.Unit.Types ( IsBootInterface(..) )
import GHC.Types.Basic ( failed )
@@ -62,7 +56,6 @@ import GHC.Types.Unique.Supply
import GHC.Types.PkgQual
import GHC.Utils.Error
-import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Monad ( liftIO, mapMaybeM )
@@ -84,21 +77,19 @@ import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
import GHC.Tc.Utils.Monad ( initIfaceCheck )
import GHC.Iface.Errors.Ppr
+import GHC.Driver.Session.Mode
+import GHC.Driver.Session.Lint
+import GHC.Driver.Session.Units
+
-- Standard Haskell libraries
import System.IO
import System.Environment
import System.Exit
-import System.FilePath
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
-import Data.Char
-import Data.List ( isPrefixOf, partition, intercalate, (\\) )
-import qualified Data.Set as Set
+import Data.List ( isPrefixOf, partition, intercalate )
import Prelude
-import GHC.ResponseFile (expandResponse)
-import Data.Bifunctor
-import GHC.Data.Graph.Directed
import qualified Data.List.NonEmpty as NE
-----------------------------------------------------------------------------
@@ -224,41 +215,9 @@ main' postLoadMode units dflags0 args flagWarnings = do
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
- (dflags3', fileish_args, dynamicFlagWarnings) <-
+ (dflags4, fileish_args, dynamicFlagWarnings) <-
GHC.parseDynamicFlags logger2 dflags2 args'
- -- When we do ghci, force using dyn ways if the target RTS linker
- -- only supports dynamic code
- let dflags3
- | LinkInMemory <- link,
- sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags3'
- = setDynamicNow $
- -- See checkOptions below, -fexternal-interpreter is
- -- required when using --interactive with a non-standard
- -- way (-prof, -static, or -dynamic).
- setGeneralFlag' Opt_ExternalInterpreter $
- -- Use .o for dynamic object, otherwise it gets dropped
- -- with "Warning: ignoring unrecognised input", see
- -- objish_suffixes
- dflags3' { dynObjectSuf_ = objectSuf dflags3' }
- | otherwise
- = dflags3'
-
- let dflags4 = if backendNeedsFullWays bcknd &&
- not (gopt Opt_ExternalInterpreter dflags3)
- then
- let platform = targetPlatform dflags3
- dflags3a = dflags3 { targetWays_ = hostFullWays }
- dflags3b = foldl gopt_set dflags3a
- $ concatMap (wayGeneralFlags platform)
- hostFullWays
- dflags3c = foldl gopt_unset dflags3b
- $ concatMap (wayUnsetGeneralFlags platform)
- hostFullWays
- in dflags3c
- else
- dflags3
-
let logger4 = setLogFlags logger2 (initLogFlags dflags4)
GHC.prettyPrintGhcErrors logger4 $ do
@@ -347,404 +306,6 @@ ghciUI units srcs maybe_expr = do
interactiveUI defaultGhciSettings hs_srcs maybe_expr
#endif
-
--- -----------------------------------------------------------------------------
--- Option sanity checks
-
--- | Ensure sanity of options.
---
--- Throws 'UsageError' or 'CmdLineError' if not.
-checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()
- -- Final sanity checking before kicking off a compilation (pipeline).
-checkOptions mode dflags srcs objs units = do
- -- Complain about any unknown flags
- let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
- when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
-
- when (not (Set.null (rtsWays (ways dflags)))
- && isInterpretiveMode mode) $
- hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
-
- -- -prof and --interactive are not a good combination
- when ((fullWays (ways dflags) /= hostFullWays)
- && isInterpretiveMode mode
- && not (gopt Opt_ExternalInterpreter dflags)) $
- do throwGhcException (UsageError
- "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
- -- -ohi sanity check
- if (isJust (outputHi dflags) &&
- (isCompManagerMode mode || srcs `lengthExceeds` 1))
- then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
- else do
-
- if (isJust (dynOutputHi dflags) &&
- (isCompManagerMode mode || srcs `lengthExceeds` 1))
- then throwGhcException (UsageError "-dynohi can only be used when compiling a single source file")
- else do
-
- -- -o sanity checking
- if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
- && not (isLinkMode mode))
- then throwGhcException (UsageError "can't apply -o to multiple source files")
- else do
-
- let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
-
- when (not_linking && not (null objs)) $
- hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
-
- -- Check that there are some input files
- -- (except in the interactive case)
- if null srcs && (null objs || not_linking) && needsInputsMode mode && null units
- then throwGhcException (UsageError "no input files" )
- else do
-
- case mode of
- StopBefore StopC | not (backendGeneratesHc (backend dflags))
- -> throwGhcException $ UsageError $
- "the option -C is only available with an unregisterised GHC"
- StopBefore StopAs | ghcLink dflags == NoLink
- -> throwGhcException $ UsageError $
- "the options -S and -fno-code are incompatible. Please omit -S"
-
- _ -> return ()
-
- -- Verify that output files point somewhere sensible.
- verifyOutputFiles dflags
-
--- Compiler output options
-
--- Called to verify that the output files point somewhere valid.
---
--- The assumption is that the directory portion of these output
--- options will have to exist by the time 'verifyOutputFiles'
--- is invoked.
---
--- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
--- they don't exist, so don't check for those here (#2278).
-verifyOutputFiles :: DynFlags -> IO ()
-verifyOutputFiles dflags = do
- let ofile = outputFile dflags
- when (isJust ofile) $ do
- let fn = fromJust ofile
- flg <- doesDirNameExist fn
- when (not flg) (nonExistentDir "-o" fn)
- let ohi = outputHi dflags
- when (isJust ohi) $ do
- let hi = fromJust ohi
- flg <- doesDirNameExist hi
- when (not flg) (nonExistentDir "-ohi" hi)
- where
- nonExistentDir flg dir =
- throwGhcException (CmdLineError ("error: directory portion of " ++
- show dir ++ " does not exist (used with " ++
- show flg ++ " option.)"))
-
------------------------------------------------------------------------------
--- GHC modes of operation
-
-type Mode = Either PreStartupMode PostStartupMode
-type PostStartupMode = Either PreLoadMode PostLoadMode
-
-data PreStartupMode
- = ShowVersion -- ghc -V/--version
- | ShowNumVersion -- ghc --numeric-version
- | ShowSupportedExtensions -- ghc --supported-extensions
- | ShowOptions Bool {- isInteractive -} -- ghc --show-options
-
-showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
-showVersionMode = mkPreStartupMode ShowVersion
-showNumVersionMode = mkPreStartupMode ShowNumVersion
-showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
-showOptionsMode = mkPreStartupMode (ShowOptions False)
-
-mkPreStartupMode :: PreStartupMode -> Mode
-mkPreStartupMode = Left
-
-isShowVersionMode :: Mode -> Bool
-isShowVersionMode (Left ShowVersion) = True
-isShowVersionMode _ = False
-
-isShowNumVersionMode :: Mode -> Bool
-isShowNumVersionMode (Left ShowNumVersion) = True
-isShowNumVersionMode _ = False
-
-data PreLoadMode
- = ShowGhcUsage -- ghc -?
- | ShowGhciUsage -- ghci -?
- | ShowInfo -- ghc --info
- | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
-
-showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
-showGhcUsageMode = mkPreLoadMode ShowGhcUsage
-showGhciUsageMode = mkPreLoadMode ShowGhciUsage
-showInfoMode = mkPreLoadMode ShowInfo
-
-printSetting :: String -> Mode
-printSetting k = mkPreLoadMode (PrintWithDynFlags f)
- where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
- $ lookup k (compilerInfo dflags)
-
-mkPreLoadMode :: PreLoadMode -> Mode
-mkPreLoadMode = Right . Left
-
-isShowGhcUsageMode :: Mode -> Bool
-isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
-isShowGhcUsageMode _ = False
-
-isShowGhciUsageMode :: Mode -> Bool
-isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
-isShowGhciUsageMode _ = False
-
-data PostLoadMode
- = ShowInterface FilePath -- ghc --show-iface
- | DoMkDependHS -- ghc -M
- | StopBefore StopPhase -- ghc -E | -C | -S
- -- StopBefore StopLn is the default
- | DoMake -- ghc --make
- | DoBackpack -- ghc --backpack foo.bkp
- | DoInteractive -- ghc --interactive
- | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
- | DoRun -- ghc --run
- | DoAbiHash -- ghc --abi-hash
- | ShowPackages -- ghc --show-packages
- | DoFrontend ModuleName -- ghc --frontend Plugin.Module
-
-doMkDependHSMode, doMakeMode, doInteractiveMode, doRunMode,
- doAbiHashMode, showUnitsMode :: Mode
-doMkDependHSMode = mkPostLoadMode DoMkDependHS
-doMakeMode = mkPostLoadMode DoMake
-doInteractiveMode = mkPostLoadMode DoInteractive
-doRunMode = mkPostLoadMode DoRun
-doAbiHashMode = mkPostLoadMode DoAbiHash
-showUnitsMode = mkPostLoadMode ShowPackages
-
-showInterfaceMode :: FilePath -> Mode
-showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
-
-stopBeforeMode :: StopPhase -> Mode
-stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
-
-doEvalMode :: String -> Mode
-doEvalMode str = mkPostLoadMode (DoEval [str])
-
-doFrontendMode :: String -> Mode
-doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
-
-doBackpackMode :: Mode
-doBackpackMode = mkPostLoadMode DoBackpack
-
-mkPostLoadMode :: PostLoadMode -> Mode
-mkPostLoadMode = Right . Right
-
-isDoInteractiveMode :: Mode -> Bool
-isDoInteractiveMode (Right (Right DoInteractive)) = True
-isDoInteractiveMode _ = False
-
-isStopLnMode :: Mode -> Bool
-isStopLnMode (Right (Right (StopBefore NoStop))) = True
-isStopLnMode _ = False
-
-isDoMakeMode :: Mode -> Bool
-isDoMakeMode (Right (Right DoMake)) = True
-isDoMakeMode _ = False
-
-isDoEvalMode :: Mode -> Bool
-isDoEvalMode (Right (Right (DoEval _))) = True
-isDoEvalMode _ = False
-
-#if defined(HAVE_INTERNAL_INTERPRETER)
-isInteractiveMode :: PostLoadMode -> Bool
-isInteractiveMode DoInteractive = True
-isInteractiveMode _ = False
-#endif
-
--- isInterpretiveMode: byte-code compiler involved
-isInterpretiveMode :: PostLoadMode -> Bool
-isInterpretiveMode DoInteractive = True
-isInterpretiveMode (DoEval _) = True
-isInterpretiveMode _ = False
-
-needsInputsMode :: PostLoadMode -> Bool
-needsInputsMode DoMkDependHS = True
-needsInputsMode (StopBefore _) = True
-needsInputsMode DoMake = True
-needsInputsMode _ = False
-
--- True if we are going to attempt to link in this mode.
--- (we might not actually link, depending on the GhcLink flag)
-isLinkMode :: PostLoadMode -> Bool
-isLinkMode (StopBefore NoStop) = True
-isLinkMode DoMake = True
-isLinkMode DoRun = True
-isLinkMode DoInteractive = True
-isLinkMode (DoEval _) = True
-isLinkMode _ = False
-
-isCompManagerMode :: PostLoadMode -> Bool
-isCompManagerMode DoRun = True
-isCompManagerMode DoMake = True
-isCompManagerMode DoInteractive = True
-isCompManagerMode (DoEval _) = True
-isCompManagerMode _ = False
-
--- -----------------------------------------------------------------------------
--- Parsing the mode flag
-
-parseModeFlags :: [Located String]
- -> IO (Mode, [String],
- [Located String],
- [Warn])
-parseModeFlags args = do
- ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <-
- processCmdLineP mode_flags (Nothing, [], [], []) args
- let mode = case mModeFlag of
- Nothing -> doMakeMode
- Just (m, _) -> m
-
- -- See Note [Handling errors when parsing command-line flags]
- unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
- map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
-
- return (mode, units, flags' ++ leftover, warns)
-
-type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String])
- -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
- -- so we collect the new ones and return them.
-
-mode_flags :: [Flag ModeM]
-mode_flags =
- [ ------- help / version ----------------------------------------------
- defFlag "?" (PassFlag (setMode showGhcUsageMode))
- , defFlag "-help" (PassFlag (setMode showGhcUsageMode))
- , defFlag "V" (PassFlag (setMode showVersionMode))
- , defFlag "-version" (PassFlag (setMode showVersionMode))
- , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
- , defFlag "-info" (PassFlag (setMode showInfoMode))
- , defFlag "-show-options" (PassFlag (setMode showOptionsMode))
- , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
- , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
- , defFlag "-show-packages" (PassFlag (setMode showUnitsMode))
- ] ++
- [ defFlag k' (PassFlag (setMode (printSetting k)))
- | k <- ["Project version",
- "Project Git commit id",
- "Booter version",
- "Stage",
- "Build platform",
- "Host platform",
- "Target platform",
- "Have interpreter",
- "Object splitting supported",
- "Have native code generator",
- "Support SMP",
- "Unregisterised",
- "Tables next to code",
- "RTS ways",
- "Leading underscore",
- "Debug on",
- "LibDir",
- "Global Package DB",
- "C compiler flags",
- "C compiler link flags"
- ],
- let k' = "-print-" ++ map (replaceSpace . toLower) k
- replaceSpace ' ' = '-'
- replaceSpace c = c
- ] ++
- ------- interfaces ----------------------------------------------------
- [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
- "--show-iface"))
-
- ------- primary modes ------------------------------------------------
- , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode NoStop) f
- addFlag "-no-link" f))
- , defFlag "M" (PassFlag (setMode doMkDependHSMode))
- , defFlag "E" (PassFlag (setMode (stopBeforeMode StopPreprocess )))
- , defFlag "C" (PassFlag (setMode (stopBeforeMode StopC)))
- , defFlag "S" (PassFlag (setMode (stopBeforeMode StopAs)))
- , defFlag "-run" (PassFlag (setMode doRunMode))
- , defFlag "-make" (PassFlag (setMode doMakeMode))
- , defFlag "unit" (SepArg (\s -> addUnit s "-unit"))
- , defFlag "-backpack" (PassFlag (setMode doBackpackMode))
- , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
- , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
- , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
- , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))
- ]
-
-addUnit :: String -> String -> EwM ModeM ()
-addUnit unit_str _arg = liftEwM $ do
- (mModeFlag, units, errs, flags') <- getCmdLineState
- putCmdLineState (mModeFlag, unit_str:units, errs, flags')
-
-setMode :: Mode -> String -> EwM ModeM ()
-setMode newMode newFlag = liftEwM $ do
- (mModeFlag, units, errs, flags') <- getCmdLineState
- let (modeFlag', errs') =
- case mModeFlag of
- Nothing -> ((newMode, newFlag), errs)
- Just (oldMode, oldFlag) ->
- case (oldMode, newMode) of
- -- -c/--make are allowed together, and mean --make -no-link
- _ | isStopLnMode oldMode && isDoMakeMode newMode
- || isStopLnMode newMode && isDoMakeMode oldMode ->
- ((doMakeMode, "--make"), [])
-
- -- If we have both --help and --interactive then we
- -- want showGhciUsage
- _ | isShowGhcUsageMode oldMode &&
- isDoInteractiveMode newMode ->
- ((showGhciUsageMode, oldFlag), [])
- | isShowGhcUsageMode newMode &&
- isDoInteractiveMode oldMode ->
- ((showGhciUsageMode, newFlag), [])
-
- -- If we have both -e and --interactive then -e always wins
- _ | isDoEvalMode oldMode &&
- isDoInteractiveMode newMode ->
- ((oldMode, oldFlag), [])
- | isDoEvalMode newMode &&
- isDoInteractiveMode oldMode ->
- ((newMode, newFlag), [])
-
- -- Otherwise, --help/--version/--numeric-version always win
- | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
- | isDominantFlag newMode -> ((newMode, newFlag), [])
- -- We need to accumulate eval flags like "-e foo -e bar"
- (Right (Right (DoEval esOld)),
- Right (Right (DoEval [eNew]))) ->
- ((Right (Right (DoEval (eNew : esOld))), oldFlag),
- errs)
- -- Saying e.g. --interactive --interactive is OK
- _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
-
- -- --interactive and --show-options are used together
- (Right (Right DoInteractive), Left (ShowOptions _)) ->
- ((Left (ShowOptions True),
- "--interactive --show-options"), errs)
- (Left (ShowOptions _), (Right (Right DoInteractive))) ->
- ((Left (ShowOptions True),
- "--show-options --interactive"), errs)
- -- Otherwise, complain
- _ -> let err = flagMismatchErr oldFlag newFlag
- in ((oldMode, oldFlag), err : errs)
- putCmdLineState (Just modeFlag', units, errs', flags')
- where isDominantFlag f = isShowGhcUsageMode f ||
- isShowGhciUsageMode f ||
- isShowVersionMode f ||
- isShowNumVersionMode f
-
-flagMismatchErr :: String -> String -> String
-flagMismatchErr oldFlag newFlag
- = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
-
-addFlag :: String -> String -> EwM ModeM ()
-addFlag s flag = liftEwM $ do
- (m, units, e, flags') <- getCmdLineState
- putCmdLineState (m, units, e, mkGeneralLocated loc s : flags')
- where loc = "addFlag by " ++ flag ++ " on the commandline"
-
-- ----------------------------------------------------------------------------
-- Run --make mode
@@ -786,181 +347,6 @@ initMake srcs = do
_ <- GHC.setSessionDynFlags dflags'
return hs_srcs
--- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
-removeRTS :: [String] -> [String]
-removeRTS ("+RTS" : xs) =
- case dropWhile (/= "-RTS") xs of
- [] -> []
- (_ : ys) -> removeRTS ys
-removeRTS (y:ys) = y : removeRTS ys
-removeRTS [] = []
-
-initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)])
-initMulti unitArgsFiles = do
- hsc_env <- GHC.getSession
- let logger = hsc_logger hsc_env
- initial_dflags <- GHC.getSessionDynFlags
-
- dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do
- when (verbosity initial_dflags > 2) (liftIO $ print f)
- args <- liftIO $ expandResponse [f]
- (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))
- handleSourceError (\e -> do
- GHC.printException e
- liftIO $ exitWith (ExitFailure 1)) $ do
- liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)
-
- let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)
- dflags4 = offsetDynFlags dflags3
-
- let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
-
- -- This is dubious as the whole unit environment won't be set-up correctly, but
- -- that doesn't matter for what we use it for (linking and oneShot)
- let dubious_hsc_env = hscSetFlags dflags4 hsc_env
- -- if we have no haskell sources from which to do a dependency
- -- analysis, then just do one-shot compilation and/or linking.
- -- This means that "ghc Foo.o Bar.o -o baz" links the program as
- -- we expect.
- if (null hs_srcs)
- then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])
- else do
-
- o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)
- non_hs_srcs
- let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files
- ++ ldInputs dflags4 }
-
- liftIO $ checkOptions DoMake dflags5 srcs objs []
-
- pure (dflags5, hs_srcs)
-
- let
- unitDflags = NE.map fst dynFlagsAndSrcs
- srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs
- (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))
-
- checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))
-
- (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags
- let home_units = HUG.allUnits initial_home_graph
-
- home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
- let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
- hue_flags = homeUnitEnv_dflags homeUnitEnv
- dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
-
- updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
- emptyHpt <- liftIO $ emptyHomePackageTable
- pure $ HomeUnitEnv
- { homeUnitEnv_units = unit_state
- , homeUnitEnv_unit_dbs = Just dbs
- , homeUnitEnv_dflags = updated_dflags
- , homeUnitEnv_hpt = emptyHpt
- , homeUnitEnv_home_unit = Just home_unit
- }
-
- checkUnitCycles initial_dflags home_unit_graph
-
- let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph
- unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
-
- GHC.setSession final_hsc_env
-
- -- if we have no haskell sources from which to do a dependency
- -- analysis, then just do one-shot compilation and/or linking.
- -- This means that "ghc Foo.o Bar.o -o baz" links the program as
- -- we expect.
- if (null hs_srcs)
- then do
- liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."
- liftIO $ exitWith (ExitFailure 1)
- else do
-
-{-
- o_files <- liftIO $ mapMaybeM
- (\(src, uid, mphase) ->
- compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)
- )
- (concat non_hs_srcs)
- -}
-
- -- MP: This should probably modify dflags for each unit?
- --let dflags' = dflags { ldInputs = map (FileOption "") o_files
- -- ++ ldInputs dflags }
- return $ concat hs_srcs
-
-checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc ()
-checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
- where
-
- processSCCs [] = return ()
- processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs
- processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
-
-
- cycle_err uids =
- hang (text "Units form a dependency cycle:")
- 2
- (one_err uids)
-
- one_err uids = vcat $
- (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)
- ++ [text "-" <+> ppr final]
- where
- start = init uids
- final = last uids
-
--- | Check that we don't have multiple units with the same UnitId.
-checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
-checkDuplicateUnits dflags flags =
- unless (null duplicate_ids)
- (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)
-
- where
- uids = map (second homeUnitId_) flags
- deduplicated_uids = ordNubOn snd uids
- duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)
-
- duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids
-
- one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp
-
- multi_err =
- hang (text "Multiple units with the same unit-id:")
- 2
- (vcat (map one_err duplicate_flags))
-
-
-offsetDynFlags :: DynFlags -> DynFlags
-offsetDynFlags dflags =
- dflags { hiDir = c hiDir
- , objectDir = c objectDir
- , stubDir = c stubDir
- , hieDir = c hieDir
- , dumpDir = c dumpDir }
-
- where
- c f = augment_maybe (f dflags)
-
- augment_maybe Nothing = Nothing
- augment_maybe (Just f) = Just (augment f)
- augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f
- | otherwise = f
-
-
-createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
-createUnitEnvFromFlags unitDflags = do
- unitEnvList <- forM unitDflags $ \dflags -> do
- emptyHpt <- emptyHomePackageTable
- let newInternalUnitEnv =
- HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing
- return (homeUnitId_ dflags, newInternalUnitEnv)
- let activeUnit = fst $ NE.head unitEnvList
- return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)
-
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
@@ -1145,14 +531,3 @@ abiHash strs = do
putStrLn (showPpr dflags f)
--- -----------------------------------------------------------------------------
--- Util
-
-unknownFlagsErr :: [String] -> a
-unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
- where
- oneError f =
- "unrecognised flag: " ++ f ++ "\n" ++
- (case flagSuggestions (nubSort allNonDeprecatedFlags) f of
- [] -> ""
- suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -348,12 +348,14 @@ initDynFlags file = do
-- Based on GHC backpack driver doBackPack
dflags0 <- GHC.getSessionDynFlags
let parser_opts0 = GHC.initParserOpts dflags0
+ logger <- GHC.getLogger
(_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file
- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts
+ (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
-- Prevent parsing of .ghc.environment.* "package environment files"
(dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
+ logger
dflags2
[GHC.noLoc "-hide-all-packages"]
_ <- GHC.setSessionDynFlags dflags3
@@ -375,13 +377,15 @@ initDynFlagsPure fp s = do
-- as long as `parseDynamicFilePragma` is impure there seems to be
-- no reason to use it.
dflags0 <- GHC.getSessionDynFlags
+ logger <- GHC.getLogger
let parser_opts0 = GHC.initParserOpts dflags0
let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (GHC.stringToStringBuffer $ s) fp
- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo
+ (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 pragmaInfo
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
-- Prevent parsing of .ghc.environment.* "package environment files"
(dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
+ logger
dflags2
[GHC.noLoc "-hide-all-packages"]
_ <- GHC.setSessionDynFlags dflags3
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c619b43fcf950dfef646e52282d30918534142e...710ba89fba258007b6075aba9931e821cdd45f75
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c619b43fcf950dfef646e52282d30918534142e...710ba89fba258007b6075aba9931e821cdd45f75
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250314/1120636e/attachment-0001.html>
More information about the ghc-commits
mailing list