From 6032e7ef66eddfd54de1423a63083120ce441d78 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 22 Sep 2026 22:23:18 +0100 Subject: [PATCH] Fix #6961 Add `stack build --info-table-profiling` --- .stan.toml | 46 ++++----------- ChangeLog.md | 4 ++ doc/commands/bench_command.md | 5 +- doc/commands/build_command.md | 16 +++++- doc/commands/haddock_command.md | 5 +- doc/commands/test_command.md | 5 +- doc/configure/yaml/non-project.md | 2 + src/Stack/Build/Source.hs | 80 +++++++++++++++++++------- src/Stack/BuildOpts.hs | 1 + src/Stack/Config/Build.hs | 1 + src/Stack/Options/BuildMonoidParser.hs | 6 ++ src/Stack/Types/BuildOpts.hs | 2 + src/Stack/Types/BuildOptsMonoid.hs | 11 +++- tests/unit/Stack/ConfigSpec.hs | 2 + 14 files changed, 122 insertions(+), 64 deletions(-) diff --git a/.stan.toml b/.stan.toml index 5e7cfe7665..47e2586cc4 100644 --- a/.stan.toml +++ b/.stan.toml @@ -138,17 +138,6 @@ scope = "all" type = "Exclude" -# Anti-pattern: Data.ByteString.Char8.pack -[[ignore]] - id = "OBS-STAN-0203-EmXRiW-573:17" -# ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters -# ✦ Category: #AntiPattern -# ✦ File: src/Stack/Build/Backpack.hs -# -# 572 ┃ -# 573 ┃ input = S8.pack (L.intercalate "," sorted) -# 574 ┃ ^^^^^^^ - # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] id = "OBS-STAN-0203-erw24B-1150:3" @@ -204,17 +193,6 @@ # 351 ┃ hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@') # 352 ┃ ^^^^^^^ -# Anti-pattern: Slow 'nub' for lists -[[ignore]] - id = "OBS-STAN-0209-EmXRiW-328:19" -# ✦ Description: Usage of 'nub' on lists that runs in quadratic time -# ✦ Category: #AntiPattern -# ✦ File: src/Stack/Build/Backpack.hs -# -# 327 ┃ -# 328 ┃ L.nub $ collectInheritedSigs sigPkg adrMap' Set.empty -# 329 ┃ ^^^^^ - # Data types with non-strict fields # Defining lazy fields in data types can lead to unexpected space leaks # Stack uses lazy fields in many places @@ -280,36 +258,36 @@ # Anti-pattern: unsafe functions [[ignore]] - id = "OBS-STAN-0212-FNS1cF-68:17" + id = "OBS-STAN-0212-FNS1cF-69:17" # ✦ Description: Usage of unsafe functions breaks referential transparency # ✦ Category: #Unsafe #AntiPattern # ✦ File: src\Stack\BuildOpts.hs # -# 67 ┃ -# 68 ┃ buildMonoid = undefined :: BuildOptsMonoid -# 69 ┃ ^^^^^^^^^ +# 68 ┃ +# 69 ┃ buildMonoid = undefined :: BuildOptsMonoid +# 70 ┃ ^^^^^^^^^ # Anti-pattern: unsafe functions [[ignore]] - id = "OBS-STAN-0212-FNS1cF-81:14" + id = "OBS-STAN-0212-FNS1cF-82:14" # ✦ Description: Usage of unsafe functions breaks referential transparency # ✦ Category: #Unsafe #AntiPattern # ✦ File: src\Stack\BuildOpts.hs # -# 79 ┃ -# 80 ┃ toMonoid = undefined :: TestOptsMonoid -# 81 ┃ ^^^^^^^^^ +# 81 ┃ +# 82 ┃ toMonoid = undefined :: TestOptsMonoid +# 83 ┃ ^^^^^^^^^ # Anti-pattern: unsafe functions [[ignore]] - id = "OBS-STAN-0212-FNS1cF-92:15" + id = "OBS-STAN-0212-FNS1cF-93:15" # ✦ Description: Usage of unsafe functions breaks referential transparency # ✦ Category: #Unsafe #AntiPattern # ✦ File: src/Stack/BuildOpts.hs # -# 90 ┃ -# 91 ┃ beoMonoid = undefined :: BenchmarkOptsMonoid -# 92 ┃ ^^^^^^^^^ +# 92 ┃ +# 93 ┃ beoMonoid = undefined :: BenchmarkOptsMonoid +# 94 ┃ ^^^^^^^^^ # Anti-pattern: Pattern matching on '_' # Pattern matching on '_' for sum types can create maintainability issues diff --git a/ChangeLog.md b/ChangeLog.md index 76ad017b1a..435d10b8eb 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -14,6 +14,10 @@ Other enhancements: * Consider Cabal 3.18 to be a tested library and remove warnings. * Consider GHC 10.0 to be a tested compiler and remove warnings. +* Add flag `--[no-]info-table-profiling` (default: disabled) to Stack's + `build` command. Set the flag to enable info table profiling, including the + creation of a new info table for every use of a data constructor in the source + program. Bug fixes: diff --git a/doc/commands/bench_command.md b/doc/commands/bench_command.md index e4b014b39e..970ce57a04 100644 --- a/doc/commands/bench_command.md +++ b/doc/commands/bench_command.md @@ -10,8 +10,9 @@ stack bench [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS] [--only-configure] [--trace] [--profile] [--no-strip] [--[no-]library-profiling] [--[no-]executable-profiling] [--[no-]library-stripping] [--[no-]executable-stripping] - [--[no-]haddock] [--haddock-arguments HADDOCK_ARGS] - [--[no-]open] [--[no-]haddock-deps] [--[no-]haddock-internal] + [--[no-]info-table-profiling] [--[no-]haddock] + [--haddock-arguments HADDOCK_ARGS] [--[no-]open] + [--[no-]haddock-deps] [--[no-]haddock-internal] [--[no-]haddock-hyperlink-source] [--[no-]haddock-for-hackage] [--[no-]copy-bins] [--[no-]copy-compiler-tool] [--[no-]prefetch] [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty] diff --git a/doc/commands/build_command.md b/doc/commands/build_command.md index 0111f19a82..bd0bd2eef4 100644 --- a/doc/commands/build_command.md +++ b/doc/commands/build_command.md @@ -10,8 +10,8 @@ stack build [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS] [--only-configure] [--[no-]semaphore] [--trace] [--profile] [--no-strip] [--[no-]library-profiling] [--[no-]executable-profiling] [--[no-]library-stripping] - [--[no-]executable-stripping] [--[no-]haddock] - [--haddock-arguments HADDOCK_ARGS] [--[no-]open] + [--[no-]executable-stripping] [--[no-]info-table-profiling] + [--[no-]haddock] [--haddock-arguments HADDOCK_ARGS] [--[no-]open] [--[no-]haddock-deps] [--[no-]haddock-internal] [--[no-]haddock-hyperlink-source] [--[no-]haddock-for-hackage] [--[no-]copy-bins] [--[no-]copy-compiler-tool] [--[no-]prefetch] @@ -933,6 +933,18 @@ right. Later options can override the effect of earlier ones. Any GHC command line options for a package specified at Stack's command line are applied after those specified in Stack's configuration files. +### `--[no-]info-table-profiling` flag + +:octicons-tag-24: UNRELEASED + +Default: Disabled + +Set the flag to enable info table profiling, including the creation of a new +info table for every use of a data constructor in the source program. + +The flag affects the location of the local project installation directory. See +the [`stack path --local-install-root`](path_command.md) command. + ### `--[no-]library-profiling` flag Default: Disabled diff --git a/doc/commands/haddock_command.md b/doc/commands/haddock_command.md index 519fa5a933..74b75a3f05 100644 --- a/doc/commands/haddock_command.md +++ b/doc/commands/haddock_command.md @@ -10,8 +10,9 @@ stack haddock [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS] [--only-configure] [--trace] [--profile] [--no-strip] [--[no-]library-profiling] [--[no-]executable-profiling] [--[no-]library-stripping] [--[no-]executable-stripping] - [--[no-]haddock] [--haddock-arguments HADDOCK_ARGS] - [--[no-]open] [--[no-]haddock-deps] [--[no-]haddock-internal] + [--[no-]info-table-profiling] [--[no-]haddock] + [--haddock-arguments HADDOCK_ARGS] [--[no-]open] + [--[no-]haddock-deps] [--[no-]haddock-internal] [--[no-]haddock-hyperlink-source] [--[no-]haddock-for-hackage] [--[no-]copy-bins] [--[no-]copy-compiler-tool] [--[no-]prefetch] [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty] diff --git a/doc/commands/test_command.md b/doc/commands/test_command.md index 12f37f5544..6ca6773fa6 100644 --- a/doc/commands/test_command.md +++ b/doc/commands/test_command.md @@ -10,8 +10,9 @@ stack test [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS] [--only-configure] [--trace] [--profile] [--no-strip] [--[no-]library-profiling] [--[no-]executable-profiling] [--[no-]library-stripping] [--[no-]executable-stripping] - [--[no-]haddock] [--haddock-arguments HADDOCK_ARGS] - [--[no-]open] [--[no-]haddock-deps] [--[no-]haddock-internal] + [--[no-]info-table-profiling] [--[no-]haddock] + [--haddock-arguments HADDOCK_ARGS] [--[no-]open] + [--[no-]haddock-deps] [--[no-]haddock-internal] [--[no-]haddock-hyperlink-source] [--[no-]haddock-for-hackage] [--[no-]copy-bins] [--[no-]copy-compiler-tool] [--[no-]prefetch] [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty] diff --git a/doc/configure/yaml/non-project.md b/doc/configure/yaml/non-project.md index 0ce5bc9a42..a01ab8c411 100644 --- a/doc/configure/yaml/non-project.md +++ b/doc/configure/yaml/non-project.md @@ -174,6 +174,8 @@ build: executable-profiling: false library-stripping: true executable-stripping: true + # Since Stack UNRELEASED: + info-table-profiling: false # NOTE: global usage of haddock can cause build failures when documentation is # incorrectly formatted. This could also affect scripts which use Stack. diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index f981877298..61bdce6e4e 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -28,6 +28,7 @@ import qualified Data.Map.Merge.Lazy as Map import qualified Data.Map.Strict as M import qualified Data.Set as Set import qualified Distribution.PackageDescription as C +import Distribution.Version ( mkVersion ) import qualified Pantry.SHA256 as SHA256 import Stack.Build.Cache ( tryGetBuildCache ) import Stack.Build.Haddock ( shouldHaddockDeps ) @@ -53,6 +54,7 @@ import Stack.Types.BuildOptsCLI ) import Stack.Types.CabalConfigKey ( CabalConfigKey (..) ) import Stack.Types.Cache ( FileCache, FileCacheInfo (..) ) +import Stack.Types.Compiler ( getGhcVersion ) import Stack.Types.CompilerPaths ( HasCompiler, getCompilerPath ) import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) import Stack.Types.Curator ( Curator (..) ) @@ -108,15 +110,31 @@ loadSourceMap :: -> RIO env SourceMap loadSourceMap targets boptsCli sma = do logDebug "Applying and checking flags" + bconfig <- view buildConfigL let errsPackages = mapMaybe checkPackage packagesWithCliFlags - eProject <- mapM applyOptsFlagsPP (M.toList sma.project) - eDeps <- mapM applyOptsFlagsDep (M.toList targetsAndSmaDeps) + compiler = sma.compiler + ghcVersion = getGhcVersion compiler + buildOpts = bconfig.config.build + infoTableProfSupported = ghcVersion >= mkVersion [9, 2, 1] + infoTableProfUnsupportedWarning = + prettyWarnL + [ "The" + , style Shell "--info-table-profiling" + , flow "flag was specified, which is supported by GHC 9.2.1 or \ + \later. GHC version" + , fromString (versionString ghcVersion) + , flow "was found. The flag will be ignored." + ] + isInfoTableProf <- if infoTableProfSupported + then pure buildOpts.infoTableProf + else infoTableProfUnsupportedWarning >> pure False + eProject <- mapM (applyOptsFlagsPP isInfoTableProf) (M.toList sma.project) + eDeps <- mapM (applyOptsFlagsDep isInfoTableProf) (M.toList targetsAndSmaDeps) let (errsProject, project') = partitionEithers eProject (errsDeps, deps') = partitionEithers eDeps errs = errsPackages <> errsProject <> errsDeps unless (null errs) $ prettyThrowM $ InvalidFlagSpecification errs - let compiler = sma.compiler - project = M.fromList project' + let project = M.fromList project' deps = M.fromList deps' globalPkgs = pruneGlobals sma.globals (Map.keysSet deps) logDebug "SourceMap constructed" @@ -144,25 +162,30 @@ loadSourceMap targets boptsCli sma = do (const Nothing) maybeCommon applyOptsFlagsPP :: - (a, ProjectPackage) + Bool + -> (a, ProjectPackage) -> RIO env (Either UnusedFlags (a, ProjectPackage)) - applyOptsFlagsPP (name, p@ProjectPackage{ projectCommon = common }) = do - let isTarget = M.member common.name targets.targets - eCommon <- applyOptsFlags isTarget True common - pure $ (\common' -> (name, p { projectCommon = common' })) <$> eCommon + applyOptsFlagsPP + isInfoTableProf (name, p@ProjectPackage{ projectCommon = common }) = do + let isTarget = M.member common.name targets.targets + eCommon <- applyOptsFlags isInfoTableProf isTarget True common + pure $ (\common' -> (name, p { projectCommon = common' })) <$> eCommon applyOptsFlagsDep :: - (a, DepPackage) + Bool + -> (a, DepPackage) -> RIO env (Either UnusedFlags (a, DepPackage)) - applyOptsFlagsDep (name, d@DepPackage{ depCommon = common }) = do - let isTarget = M.member common.name targets.deps - eCommon <- applyOptsFlags isTarget False common - pure $ (\common' -> (name, d { depCommon = common' })) <$> eCommon + applyOptsFlagsDep + isInfoTableProf (name, d@DepPackage{ depCommon = common }) = do + let isTarget = M.member common.name targets.deps + eCommon <- applyOptsFlags isInfoTableProf isTarget False common + pure $ (\common' -> (name, d { depCommon = common' })) <$> eCommon applyOptsFlags :: Bool -> Bool + -> Bool -> CommonPackage -> RIO env (Either UnusedFlags CommonPackage) - applyOptsFlags isTarget isProjectPackage common = do + applyOptsFlags isInfoTableProf isTarget isProjectPackage common = do let name = common.name cliFlagsByName = Map.findWithDefault Map.empty (ACFByName name) cliFlags cliFlagsAll = @@ -186,8 +209,12 @@ loadSourceMap targets boptsCli sma = do then do bconfig <- view buildConfigL let bopts = bconfig.config.build - ghcOptions = - generalGhcOptions bconfig boptsCli isTarget isProjectPackage + ghcOptions = generalGhcOptions + bconfig + boptsCli + isTarget + isProjectPackage + isInfoTableProf cabalConfigOpts = generalCabalConfigOpts bconfig boptsCli @@ -245,7 +272,11 @@ hashSourceMapData boptsCli sm = do -- boot packages so we'll have different hashes when bare snapshot -- 'ghc-X.Y.Z' is used, no extra-deps and e.g. user wants builds with -- profiling or without - bootGhcOpts = map display (generalGhcOptions bc boptsCli False False) + ghcVersion = getGhcVersion sm.compiler + isInfoTableProf = + ghcVersion >= mkVersion [9, 2, 1] && bc.config.build.infoTableProf + bootGhcOpts = + map display (generalGhcOptions bc boptsCli False False isInfoTableProf) hashedContent = toLazyByteString $ compilerPath <> compilerInfo @@ -303,8 +334,14 @@ generalCabalConfigOpts bconfig boptsCli name isTarget isLocal = concat -- | Get the configured options to pass from GHC, based on the build -- configuration and commandline. -generalGhcOptions :: BuildConfig -> BuildOptsCLI -> Bool -> Bool -> [Text] -generalGhcOptions bconfig boptsCli isTarget isLocal = concat +generalGhcOptions :: + BuildConfig + -> BuildOptsCLI + -> Bool + -> Bool + -> Bool + -> [Text] +generalGhcOptions bconfig boptsCli isTarget isLocal isInfoTableProf = concat [ Map.findWithDefault [] AGOEverything config.ghcOptionsByCat , if isLocal then Map.findWithDefault [] AGOLocals config.ghcOptionsByCat @@ -317,6 +354,9 @@ generalGhcOptions bconfig boptsCli isTarget isLocal = concat then ["-fprof-auto", "-fprof-cafs"] else [] , [ "-g" | not $ bopts.libStrip || bopts.exeStrip ] + , if isInfoTableProf + then ["-finfo-table-map", "-fdistinct-constructor-tables"] + else [] , if includeExtraOptions then boptsCli.ghcOptions else [] diff --git a/src/Stack/BuildOpts.hs b/src/Stack/BuildOpts.hs index b843a5b4a8..2d38e210fc 100644 --- a/src/Stack/BuildOpts.hs +++ b/src/Stack/BuildOpts.hs @@ -35,6 +35,7 @@ defaultBuildOpts = BuildOpts , exeProfile = defaultFirstFalse buildMonoid.exeProfile , libStrip = defaultFirstTrue buildMonoid.libStrip , exeStrip = defaultFirstTrue buildMonoid.exeStrip + , infoTableProf = defaultFirstFalse buildMonoid.infoTableProf , buildHaddocks = False , haddockOpts = defaultHaddockOpts , openHaddocks = defaultFirstFalse buildMonoid.openHaddocks diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs index 3731527744..3aa3fbc4ae 100644 --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -53,6 +53,7 @@ buildOptsFromMonoid buildMonoid = BuildOpts ( buildMonoid.exeStrip <> FirstTrue (if noStripping then Just False else Nothing) ) + , infoTableProf = fromFirstFalse buildMonoid.infoTableProf , buildHaddocks = fromFirstFalse buildMonoid.buildHaddocks , haddockOpts = haddockOptsFromMonoid buildMonoid.haddockOpts , openHaddocks = diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs index 7de4eeaa78..6b77b0167c 100644 --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -44,6 +44,7 @@ buildOptsMonoidParser hide0 = BuildOptsMonoid <*> exeProfiling <*> libStripping <*> exeStripping + <*> infoTableProfiling <*> haddock <*> haddockOptsParser hideBool <*> openHaddocks @@ -131,6 +132,11 @@ buildOptsMonoidParser hide0 = BuildOptsMonoid "executable-stripping" "executable stripping for TARGETs and all its dependencies." hide + infoTableProfiling = firstBoolFlagsFalse + "info-table-profiling" + "info table profiling, including the creation of a new info table for \ + \every use of a data constructor in the source program." + hide haddock = firstBoolFlagsFalse "haddock" "generating Haddock documentation for the package(s) in this \ diff --git a/src/Stack/Types/BuildOpts.hs b/src/Stack/Types/BuildOpts.hs index cf7c335db8..1daf51c0c4 100644 --- a/src/Stack/Types/BuildOpts.hs +++ b/src/Stack/Types/BuildOpts.hs @@ -33,6 +33,8 @@ data BuildOpts = BuildOpts , exeProfile :: !Bool , libStrip :: !Bool , exeStrip :: !Bool + , infoTableProf :: !Bool + -- ^ Build with info table profiling? , buildHaddocks :: !Bool -- ^ Build Haddock documentation? , haddockOpts :: !HaddockOpts diff --git a/src/Stack/Types/BuildOptsMonoid.hs b/src/Stack/Types/BuildOptsMonoid.hs index 26847527bb..9dc8f991f0 100644 --- a/src/Stack/Types/BuildOptsMonoid.hs +++ b/src/Stack/Types/BuildOptsMonoid.hs @@ -55,6 +55,8 @@ data BuildOptsMonoid = BuildOptsMonoid , exeProfile :: !FirstFalse , libStrip :: !FirstTrue , exeStrip :: !FirstTrue + , infoTableProf :: !FirstFalse + -- ^ Build with info table profiling? , buildHaddocks :: !FirstFalse , haddockOpts :: !HaddockOptsMonoid , openHaddocks :: !FirstFalse @@ -91,9 +93,10 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where profile = Any False noStrip = Any False libProfile <- FirstFalse <$> o ..:? libProfileArgName - exeProfile <-FirstFalse <$> o ..:? exeProfileArgName + exeProfile <- FirstFalse <$> o ..:? exeProfileArgName libStrip <- FirstTrue <$> o ..:? libStripArgName - exeStrip <-FirstTrue <$> o ..:? exeStripArgName + exeStrip <- FirstTrue <$> o ..:? exeStripArgName + infoTableProf <- FirstFalse <$> o ..:? infoTableProfilingArgName buildHaddocks <- FirstFalse <$> o ..:? haddockArgName haddockOpts <- jsonSubWarnings (o ..:? haddockOptsArgName ..!= mempty) openHaddocks <- FirstFalse <$> o ..:? openHaddocksArgName @@ -133,6 +136,7 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where , exeProfile , libStrip , exeStrip + , infoTableProf , buildHaddocks , haddockOpts , openHaddocks @@ -174,6 +178,9 @@ libStripArgName = "library-stripping" exeStripArgName :: Text exeStripArgName = "executable-stripping" +infoTableProfilingArgName :: Text +infoTableProfilingArgName = "info-table-profiling" + haddockArgName :: Text haddockArgName = "haddock" diff --git a/tests/unit/Stack/ConfigSpec.hs b/tests/unit/Stack/ConfigSpec.hs index 1cfd740091..c5da6c5210 100644 --- a/tests/unit/Stack/ConfigSpec.hs +++ b/tests/unit/Stack/ConfigSpec.hs @@ -66,6 +66,7 @@ buildOptsConfig = " executable-profiling: true\n" ++ " library-stripping: false\n" ++ " executable-stripping: false\n" ++ + " info-table-profiling: true\n" ++ " haddock: true\n" ++ " haddock-arguments:\n" ++ " haddock-args:\n" ++ @@ -235,6 +236,7 @@ spec = beforeAll setup $ do bopts.exeProfile `shouldBe` True bopts.libStrip `shouldBe` False bopts.exeStrip `shouldBe` False + bopts.infoTableProf `shouldBe` True bopts.buildHaddocks `shouldBe` True bopts.haddockOpts `shouldBe` HaddockOpts { additionalArgs = ["--css=/home/user/my-css"]