[Git][ghc/ghc][wip/andreask/inlineable-threshold] 6 commits: Hadrian: fix ghcDebugAssertions off-by-one error
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Thu Dec 8 12:12:18 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/inlineable-threshold at Glasgow Haskell Compiler / GHC
Commits:
cd31acad by sheaf at 2022-12-06T15:45:58-05:00
Hadrian: fix ghcDebugAssertions off-by-one error
Commit 6b2f7ffe changed the logic that decided whether to enable debug
assertions. However, it had an off-by-one error, as the stage parameter
to the function inconsistently referred to the stage of the compiler
being used to build or the stage of the compiler we are building.
This patch makes it consistent. Now the parameter always refers to the
the compiler which is being built.
In particular, this patch re-enables
assertions in the stage 2 compiler when building with devel2 flavour,
and disables assertions in the stage 2 compiler when building with
validate flavour.
Some extra performance tests are now run in the "validate" jobs because
the stage2 compiler no longer contains assertions.
-------------------------
Metric Decrease:
CoOpt_Singletons
MultiComponentModules
MultiComponentModulesRecomp
MultiLayerModulesTH_OneShot
T11374
T12227
T12234
T13253-spj
T13701
T14683
T14697
T15703
T17096
T17516
T18304
T18478
T18923
T5030
T9872b
TcPlugin_RewritePerf
Metric Increase:
MultiComponentModules
MultiComponentModulesRecomp
MultiLayerModules
MultiLayerModulesRecomp
MultiLayerModulesTH_Make
T13386
T13719
T3294
T9233
T9675
parsing001
-------------------------
- - - - -
21d66db1 by mrkun at 2022-12-06T15:46:38-05:00
Push DynFlags out of runInstallNameTool
- - - - -
aaaaa79b by mrkun at 2022-12-06T15:46:38-05:00
Push DynFlags out of askOtool
- - - - -
4e28f49e by mrkun at 2022-12-06T15:46:38-05:00
Push DynFlags out of runInjectRPaths
- - - - -
a7422580 by mrkun at 2022-12-06T15:46:38-05:00
Push DynFlags out of Linker.MacOS
- - - - -
afef9b0e by Andreas Klebinger at 2022-12-08T13:08:30+01:00
Make INLINEABLE guidance based on optimized form.
We know that if inlined these will optimize to something more similar to
their optimized rhs than to the unoptimized unfolding. So make inlining
decisions based on the optimized rhs instead of the unoptimized
unfolding.
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
- + compiler/GHC/Driver/Config/Linker.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/IfaceToCore.hs
- + compiler/GHC/Linker/Config.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/MacOS.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/ghc.cabal.in
- hadrian/doc/user-settings.md
- hadrian/src/Flavour/Type.hs
- hadrian/src/Settings/Builders/RunTest.hs
- hadrian/src/Settings/Flavours/Development.hs
- hadrian/src/Settings/Packages.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -4198,7 +4198,7 @@ simplLetUnfolding :: SimplEnv
-> Unfolding -> SimplM Unfolding
simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
| isStableUnfolding unf
- = simplStableUnfolding env bind_cxt id rhs_ty arity unf
+ = simplStableUnfolding env bind_cxt id rhs_ty arity unf new_rhs
| isExitJoinId id
= return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
| otherwise
@@ -4230,9 +4230,10 @@ simplStableUnfolding :: SimplEnv -> BindContext
-> OutType
-> ArityType -- Used to eta expand, but only for non-join-points
-> Unfolding
+ -> CoreExpr
->SimplM Unfolding
-- Note [Setting the new unfolding]
-simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
+simplStableUnfolding env bind_cxt id rhs_ty id_arity unf opt_rhs
= case unf of
NoUnfolding -> return unf
BootUnfolding -> return unf
@@ -4243,38 +4244,57 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
; args' <- mapM (simplExpr env') args
; return (mkDFunUnfolding bndrs' con args') }
+
CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
| isStableSource src
- -> do { expr' <- case bind_cxt of
+ -> do { unf_expr' <- case bind_cxt of
BC_Join _ cont -> -- Binder is a join point
-- See Note [Rules and unfolding for join points]
simplJoinRhs unf_env id expr cont
BC_Let _ is_rec -> -- Binder is not a join point
do { let cont = mkRhsStop rhs_ty is_rec topDmd
-- mkRhsStop: switch off eta-expansion at the top level
- ; expr' <- simplExprC unf_env expr cont
- ; return (eta_expand expr') }
+ ; unf_expr' <- simplExprC unf_env expr cont
+ ; return (eta_expand unf_expr') }
; case guide of
+ -- If we ever considered it ok to inline the stable expression keep
+ -- it that way.
UnfWhen { ug_boring_ok = boring_ok }
-- Happens for INLINE things
-- Really important to force new_boring_ok since otherwise
-- `ug_boring_ok` is a thunk chain of
-- inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ...
-- See #20134
- -> let !new_boring_ok = boring_ok || inlineBoringOk expr'
+ -> let !new_boring_ok = boring_ok || inlineBoringOk unf_expr'
guide' = guide { ug_boring_ok = new_boring_ok }
- -- Refresh the boring-ok flag, in case expr'
+ -- Refresh the boring-ok flag, in case unf_expr'
-- has got small. This happens, notably in the inlinings
-- for dfuns for single-method classes; see
-- Note [Single-method classes] in GHC.Tc.TyCl.Instance.
-- A test case is #4138
-- But retain a previous boring_ok of True; e.g. see
-- the way it is set in calcUnfoldingGuidanceWithArity
- in return (mkCoreUnfolding src is_top_lvl expr' guide')
+ in return (mkCoreUnfolding src is_top_lvl unf_expr' guide')
-- See Note [Top-level flag on inline rules] in GHC.Core.Unfold
-
- _other -- Happens for INLINABLE things
- -> mkLetUnfolding uf_opts top_lvl src id expr' }
+ -- The unoptimized unfolding might be too big to inline. Calculate guidance
+ -- based on the size of the optimized core. After all this is what the unfolding
+ -- will optimize to eventually!
+ _other -> do
+ let rhs_guide = calcUnfoldingGuidance uf_opts (is_top_lvl && is_bottoming) src opt_rhs
+ return (mkCoreUnfolding src is_top_lvl unf_expr' rhs_guide)
+
+ -- return $ CoreUnfolding { uf_tmpl = unf_expr', uf_src = src, uf_guidance = rhs_guide }
+ }
+
+ -- UnfIfGoodArgs {ug_args=_ug_args, ug_size=_ug_size, ug_res=_ug_res}
+ -- -- Happens for INLINEABLE things
+ -- -> do fake_unfolding <- mkLetUnfolding uf_opts top_lvl src id opt_rhs
+ -- case fake_unfolding of
+ -- CoreUnfolding { uf_guidance = new_guideance }
+ -- -> return $ fake_unfolding { uf_tmpl = unf_expr' }
+ -- _ -> mkLetUnfolding uf_opts top_lvl src id unf_expr'
+ -- _other -- Happens for INLINABLE things too big to ever inline
+ -- -> mkLetUnfolding uf_opts top_lvl src id unf_expr' }
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
@@ -4286,6 +4306,7 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
-- is small and easy to compute so might as well force it.
top_lvl = bindContextLevel bind_cxt
!is_top_lvl = isTopLevel top_lvl
+ is_bottoming = isDeadEndId id
act = idInlineActivation id
unf_env = updMode (updModeForStableUnfoldings act) env
-- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -229,12 +229,13 @@ inlineBoringOk e
calcUnfoldingGuidance
:: UnfoldingOpts
-> Bool -- Definitely a top-level, bottoming binding
+ -> UnfoldingSource -- Tells us if this is a stable unfolding
-> CoreExpr -- Expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)
+calcUnfoldingGuidance opts is_top_bottoming src (Tick t expr)
| not (tickishIsCode t) -- non-code ticks don't matter for unfolding
- = calcUnfoldingGuidance opts is_top_bottoming expr
-calcUnfoldingGuidance opts is_top_bottoming expr
+ = calcUnfoldingGuidance opts is_top_bottoming src expr
+calcUnfoldingGuidance opts is_top_bottoming src expr
= case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of
TooBig -> UnfNever
SizeIs size cased_bndrs scrut_discount
@@ -253,8 +254,8 @@ calcUnfoldingGuidance opts is_top_bottoming expr
where
(bndrs, body) = collectBinders expr
+ -- Bomb out if size gets bigger than this
bOMB_OUT_SIZE = unfoldingCreationThreshold opts
- -- Bomb out if size gets bigger than this
val_bndrs = filter isId bndrs
n_val_bndrs = length val_bndrs
=====================================
compiler/GHC/Core/Unfold/Make.hs
=====================================
@@ -107,7 +107,7 @@ mkWorkerUnfolding opts work_fn
= mkCoreUnfolding src top_lvl new_tmpl guidance
where
new_tmpl = simpleOptExpr opts (work_fn tmpl)
- guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl
+ guidance = calcUnfoldingGuidance (so_uf_opts opts) False src new_tmpl
mkWorkerUnfolding _ _ _ = noUnfolding
@@ -317,7 +317,7 @@ mkUnfolding opts src top_lvl is_bottoming expr
= mkCoreUnfolding src top_lvl expr guidance
where
is_top_bottoming = top_lvl && is_bottoming
- guidance = calcUnfoldingGuidance opts is_top_bottoming expr
+ guidance = calcUnfoldingGuidance opts is_top_bottoming src expr
-- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
=====================================
compiler/GHC/Driver/Config/Linker.hs
=====================================
@@ -0,0 +1,13 @@
+module GHC.Driver.Config.Linker
+ ( initFrameworkOpts
+ ) where
+
+import GHC.Linker.Config
+
+import GHC.Driver.Session
+
+initFrameworkOpts :: DynFlags -> FrameworkOpts
+initFrameworkOpts dflags = FrameworkOpts
+ { foFrameworkPaths = frameworkPaths dflags
+ , foCmdlineFrameworks = cmdlineFrameworks dflags
+ }
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -130,7 +130,7 @@ module GHC.Driver.Session (
versionedAppDir, versionedFilePath,
extraGccViaCFlags, globalPackageDatabasePath,
pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,
- pgm_windres, pgm_ar, pgm_otool, pgm_install_name_tool,
+ pgm_windres, 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_lm, opt_i,
opt_P_signature,
@@ -833,10 +833,6 @@ 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_otool :: DynFlags -> String
-pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags
-pgm_install_name_tool :: DynFlags -> String
-pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags
pgm_ranlib :: DynFlags -> String
pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags
pgm_lo :: DynFlags -> (String,[Option])
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1781,7 +1781,7 @@ tcUnfolding toplvl name _ info (IfCoreUnfold src if_guidance if_expr)
; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr
; let guidance = case if_guidance of
IfWhen arity unsat_ok boring_ok -> UnfWhen arity unsat_ok boring_ok
- IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming expr
+ IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming src expr
; return $ mkCoreUnfolding src True expr guidance }
where
-- Strictness should occur before unfolding!
=====================================
compiler/GHC/Linker/Config.hs
=====================================
@@ -0,0 +1,13 @@
+-- | Linker configuration
+
+module GHC.Linker.Config
+ ( FrameworkOpts(..)
+ ) where
+
+import GHC.Prelude
+
+-- used on darwin only
+data FrameworkOpts = FrameworkOpts
+ { foFrameworkPaths :: [String]
+ , foCmdlineFrameworks :: [String]
+ }
=====================================
compiler/GHC/Linker/Dynamic.hs
=====================================
@@ -12,6 +12,7 @@ import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways
+import GHC.Driver.Config.Linker
import GHC.Driver.Session
import GHC.Unit.Env
@@ -23,6 +24,7 @@ import GHC.SysTools.Tasks
import GHC.Utils.Logger
import GHC.Utils.TmpFs
+import Control.Monad (when)
import System.FilePath
linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
@@ -94,7 +96,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- frameworks
pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)
- let framework_opts = getFrameworkOpts dflags platform
+ let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform
case os of
OSMinGW32 -> do
@@ -193,7 +195,9 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- See Note [Dynamic linking on macOS]
++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
)
- runInjectRPaths logger dflags pkg_lib_paths output_fn
+ -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
+ when (gopt Opt_RPath dflags) $
+ runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
_ -> do
-------------------------------------------------------------------
-- Making a DSO
=====================================
compiler/GHC/Linker/MacOS.hs
=====================================
@@ -9,12 +9,15 @@ where
import GHC.Prelude
import GHC.Platform
+import GHC.Linker.Config
+
import GHC.Driver.Session
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Env
+import GHC.Settings
import GHC.SysTools.Tasks
import GHC.Runtime.Interpreter
@@ -46,15 +49,13 @@ import Text.ParserCombinators.ReadP as Parser
-- dynamic library through @-add_rpath at .
--
-- See Note [Dynamic linking on macOS]
-runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
--- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004
-runInjectRPaths _ dflags _ _ | not (gopt Opt_RPath dflags) = return ()
-runInjectRPaths logger dflags lib_paths dylib = do
- info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib]
+runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO ()
+runInjectRPaths logger toolSettings lib_paths dylib = do
+ info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib]
-- filter the output for only the libraries. And then drop the @rpath prefix.
let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
-- find any pre-existing LC_PATH items
- info <- lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib]
+ info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib]
let paths = mapMaybe get_rpath info
lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
-- only find those rpaths, that aren't already in the library.
@@ -62,7 +63,7 @@ runInjectRPaths logger dflags lib_paths dylib = do
-- inject the rpaths
case rpaths of
[] -> return ()
- _ -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
+ _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
get_rpath :: String -> Maybe FilePath
get_rpath l = case readP_to_S rpath_parser l of
@@ -96,15 +97,15 @@ getUnitFrameworkOpts unit_env dep_packages
| otherwise = return []
-getFrameworkOpts :: DynFlags -> Platform -> [String]
-getFrameworkOpts dflags platform
+getFrameworkOpts :: FrameworkOpts -> Platform -> [String]
+getFrameworkOpts fwOpts platform
| platformUsesFrameworks platform = framework_path_opts ++ framework_opts
| otherwise = []
where
- framework_paths = frameworkPaths dflags
+ framework_paths = foFrameworkPaths fwOpts
framework_path_opts = map ("-F" ++) framework_paths
- frameworks = cmdlineFrameworks dflags
+ frameworks = foCmdlineFrameworks fwOpts
-- reverse because they're added in reverse order from the cmd line:
framework_opts = concat [ ["-framework", fw]
| fw <- reverse frameworks ]
=====================================
compiler/GHC/Linker/Static.hs
=====================================
@@ -29,6 +29,7 @@ import GHC.Linker.ExtraObj
import GHC.Linker.Windows
import GHC.Linker.Static.Utils
+import GHC.Driver.Config.Linker
import GHC.Driver.Session
import System.FilePath
@@ -171,7 +172,7 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
-- frameworks
pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units
- let framework_opts = getFrameworkOpts dflags platform
+ let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform
-- probably _stub.o files
let extra_ld_inputs = ldInputs dflags
@@ -183,7 +184,9 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
let link dflags args | platformOS platform == OSDarwin
= do
GHC.SysTools.runLink logger tmpfs dflags args
- GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn
+ -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
+ when (gopt Opt_RPath dflags) $
+ GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
| otherwise
= GHC.SysTools.runLink logger tmpfs dflags args
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.IO (catchException)
import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
+import GHC.Settings
+
import GHC.SysTools.Process
import GHC.SysTools.Info
@@ -362,15 +364,15 @@ runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do
let ar = pgm_ar dflags
runSomethingFiltered logger id "Ar" ar args cwd Nothing
-askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String
-askOtool logger dflags mb_cwd args = do
- let otool = pgm_otool dflags
+askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String
+askOtool logger toolSettings mb_cwd args = do
+ let otool = toolSettings_pgm_otool toolSettings
runSomethingWith logger "otool" otool args $ \real_args ->
readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
-runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
-runInstallNameTool logger dflags args = do
- let tool = pgm_install_name_tool dflags
+runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO ()
+runInstallNameTool logger toolSettings args = do
+ let tool = toolSettings_pgm_install_name_tool toolSettings
runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing
runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
=====================================
compiler/ghc.cabal.in
=====================================
@@ -421,6 +421,7 @@ Library
GHC.Driver.Config.HsToCore
GHC.Driver.Config.HsToCore.Ticks
GHC.Driver.Config.HsToCore.Usage
+ GHC.Driver.Config.Linker
GHC.Driver.Config.Logger
GHC.Driver.Config.Parser
GHC.Driver.Config.Stg.Debug
@@ -529,6 +530,7 @@ Library
GHC.JS.Syntax
GHC.JS.Transform
GHC.Linker
+ GHC.Linker.Config
GHC.Linker.Dynamic
GHC.Linker.ExtraObj
GHC.Linker.Loader
=====================================
hadrian/doc/user-settings.md
=====================================
@@ -25,7 +25,7 @@ data Flavour = Flavour {
packages :: Stage -> Action [Package],
-- | Bignum backend: 'native', 'gmp', 'ffi', etc.
bignumBackend :: String,
- -- | Check bignum backend against native
+ -- | Check selected bignum backend against native backend
bignumCheck :: Bool,
-- | Build libraries these ways.
libraryWays :: Ways,
@@ -34,15 +34,20 @@ data Flavour = Flavour {
-- | Build dynamic GHC programs.
dynamicGhcPrograms :: Action Bool,
-- | Enable GHCi debugger.
- ghciWithDebugger :: Bool,
+ ghciWithDebugger :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build profiled GHC.
- ghcProfiled :: Bool,
+ ghcProfiled :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build GHC with the debug RTS.
- ghcDebugged :: Bool,
+ ghcDebugged :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build GHC with debug assertions (-DDEBUG).
- ghcDebugAssertions :: Bool,
+ ghcDebugAssertions :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build the GHC executable against the threaded runtime system.
- ghcThreaded :: Bool,
+ ghcThreaded :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Whether to build docs and which ones
-- (haddocks, user manual, haddock manual)
ghcDocs :: Action DocTargets }
=====================================
hadrian/src/Flavour/Type.hs
=====================================
@@ -18,9 +18,9 @@ data Flavour = Flavour {
args :: Args,
-- | Build these packages.
packages :: Stage -> Action [Package],
- -- | 'native', 'gmp', 'ffi'.
+ -- | Bignum backend: 'native', 'gmp', 'ffi', etc.
bignumBackend :: String,
- -- | Check selected backend against native backend
+ -- | Check selected bignum backend against native backend
bignumCheck :: Bool,
-- | Build libraries these ways.
libraryWays :: Ways,
@@ -29,15 +29,20 @@ data Flavour = Flavour {
-- | Build dynamic GHC programs.
dynamicGhcPrograms :: Action Bool,
-- | Enable GHCi debugger.
- ghciWithDebugger :: Stage -> Bool,
+ ghciWithDebugger :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build profiled GHC.
- ghcProfiled :: Stage -> Bool,
+ ghcProfiled :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build GHC with the debug RTS.
- ghcDebugged :: Stage -> Bool,
- -- | Build GHC with debug assertions.
- ghcDebugAssertions :: Stage -> Bool,
+ ghcDebugged :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
+ -- | Build GHC with debug assertions (-DDEBUG).
+ ghcDebugAssertions :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build the GHC executable against the threaded runtime system.
- ghcThreaded :: Stage -> Bool,
+ ghcThreaded :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Whether to build docs and which ones
-- (haddocks, user manual, haddock manual)
ghcDocs :: Action DocTargets }
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -101,7 +101,7 @@ inTreeCompilerArgs stg = do
unregisterised <- flag GhcUnregisterised
tables_next_to_code <- flag TablesNextToCode
withSMP <- targetSupportsSMP
- debugAssertions <- ($ stg) . ghcDebugAssertions <$> flavour
+ debugAssertions <- ($ succStage stg) . ghcDebugAssertions <$> flavour
profiled <- ghcProfiled <$> flavour <*> pure stg
os <- setting HostOs
=====================================
hadrian/src/Settings/Flavours/Development.hs
=====================================
@@ -16,12 +16,12 @@ developmentFlavour ghcStage = defaultFlavour
, libraryWays = pure $ Set.fromList [vanilla]
, rtsWays = Set.fromList <$> mconcat [pure [vanilla, debug], targetSupportsThreadedRts ? pure [threaded, threadedDebug]]
, dynamicGhcPrograms = return False
- , ghcDebugAssertions = (>= Stage2) }
+ , ghcDebugAssertions = (== ghcStage) }
where
stageString Stage2 = "2"
stageString Stage1 = "1"
stageString Stage3 = "3"
- stageString s = error ("developmentFlavour not support for " ++ show s)
+ stageString s = error ("developmentFlavour not supported for " ++ show s)
developmentArgs :: Stage -> Args
developmentArgs ghcStage = do
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -13,7 +13,6 @@ packageArgs :: Args
packageArgs = do
stage <- getStage
path <- getBuildPath
- root <- getBuildRoot
compilerPath <- expr $ buildPath (vanillaContext stage compiler)
let -- Do not bind the result to a Boolean: this forces the configure rule
@@ -29,7 +28,10 @@ packageArgs = do
cursesLibraryDir <- getSetting CursesLibDir
ffiIncludeDir <- getSetting FfiIncludeDir
ffiLibraryDir <- getSetting FfiLibDir
- debugAssertions <- ghcDebugAssertions <$> expr flavour
+ debugAssertions <- ( `ghcDebugAssertions` (succStage stage) ) <$> expr flavour
+ -- NB: in this function, "stage" is the stage of the compiler we are
+ -- using to build, but ghcDebugAssertions wants the stage of the compiler
+ -- we are building, which we get using succStage.
mconcat
--------------------------------- base ---------------------------------
@@ -52,7 +54,7 @@ packageArgs = do
[ builder Alex ? arg "--latin1"
, builder (Ghc CompileHs) ? mconcat
- [ debugAssertions stage ? arg "-DDEBUG"
+ [ debugAssertions ? arg "-DDEBUG"
, inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto"
, input "**/Parser.hs" ?
@@ -83,7 +85,7 @@ packageArgs = do
, package ghc ? mconcat
[ builder Ghc ? mconcat
[ arg ("-I" ++ compilerPath)
- , debugAssertions stage ? arg "-DDEBUG" ]
+ , debugAssertions ? arg "-DDEBUG" ]
, builder (Cabal Flags) ? mconcat
[ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e64712c0f0069dbd70eab760232d981af2c4a9e3...afef9b0e3123041b156e785291682fc3a5c4a04e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e64712c0f0069dbd70eab760232d981af2c4a9e3...afef9b0e3123041b156e785291682fc3a5c4a04e
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/20221208/fd75c10e/attachment-0001.html>
More information about the ghc-commits
mailing list