[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Stricter Binary.get in GHC.Types.Unit (#23964)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 10 08:08:53 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a0ab7850 by Sebastian Graf at 2023-10-10T04:08:41-04:00
Stricter Binary.get in GHC.Types.Unit (#23964)
I noticed some thunking while looking at Core.
This change has very modest, but throughout positive ghc/alloc effect:
```
hard_hole_fits(normal) ghc/alloc 283,057,664 281,620,872 -0.5%
geo. mean -0.1%
minimum -0.5%
maximum +0.0%
```
Fixes #23964.
- - - - -
b952dcc3 by doyougnu at 2023-10-10T04:08:44-04:00
ci: add javascript label rule
This adds a rule which triggers the javascript job when the "javascript"
label is assigned to an MR.
- - - - -
60ce84eb by Matthew Craven at 2023-10-10T04:08:44-04:00
Make 'wWarningFlagsDeps' include every WarningFlag
Fixes #24071.
- - - - -
5 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Unit/Types.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -604,6 +604,7 @@ data Rule = ReleaseOnly -- ^ Only run this job in a release pipeline
data ValidateRule =
FullCI -- ^ Run this job when the "full-ci" label is present.
| LLVMBackend -- ^ Run this job when the "LLVM backend" label is present
+ | JSBackend -- ^ Run this job when the "javascript" label is present
| FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
| NonmovingGc -- ^ Run this job when the "non-moving GC" label is set.
| IpeData -- ^ Run this job when the "IPE" label is set
@@ -648,11 +649,12 @@ validateRuleString FullCI = or_all ([ labelString "full-ci"
, branchStringLike "ghc-[0-9]+\\.[0-9]+"
])
-validateRuleString LLVMBackend = labelString "LLVM backend"
+validateRuleString LLVMBackend = labelString "LLVM backend"
+validateRuleString JSBackend = labelString "javascript"
validateRuleString FreeBSDLabel = labelString "FreeBSD"
-validateRuleString NonmovingGc = labelString "non-moving GC"
-validateRuleString IpeData = labelString "IPE"
-validateRuleString TestPrimops = labelString "test-primops"
+validateRuleString NonmovingGc = labelString "non-moving GC"
+validateRuleString IpeData = labelString "IPE"
+validateRuleString TestPrimops = labelString "test-primops"
-- | A 'Job' is the description of a single job in a gitlab pipeline. The
-- job contains all the information about how to do the build but can be further
@@ -1010,10 +1012,9 @@ job_groups =
, disableValidate (standardBuildsWithConfig AArch64 (Linux Alpine318) (splitSectionsBroken vanilla))
, fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine312) staticNativeInt)))
, validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
- , validateBuilds Amd64 (Linux Debian11) (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure")
- )
- { bignumBackend = Native
- }
+
+ , addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11) javascriptConfig)
+
, make_wasm_jobs wasm_build_config
, modifyValidateJobs manual $
make_wasm_jobs wasm_build_config {bignumBackend = Native}
@@ -1024,6 +1025,8 @@ job_groups =
]
where
+ javascriptConfig = (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure"))
+ { bignumBackend = Native }
-- ghcilink002 broken due to #17869
--
=====================================
.gitlab/jobs.yaml
=====================================
@@ -5255,7 +5255,7 @@
],
"rules": [
{
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*javascript.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "on_success"
}
],
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -695,7 +695,7 @@ data WarningFlag =
| Opt_WarnIncompleteRecordSelectors -- Since 9.10
| Opt_WarnBadlyStagedTypes -- Since 9.10
| Opt_WarnInconsistentFlags -- Since 9.8
- deriving (Eq, Ord, Show, Enum)
+ deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
--
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2165,127 +2165,125 @@ wWarningFlags :: [FlagSpec WarningFlag]
wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)
wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]
-wWarningFlagsDeps = mconcat [
+wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
-- See Note [Updating flag description in the User's Guide]
-- See Note [Supporting CLI completion]
--- Please keep the list of flags below sorted alphabetically
- warnSpec Opt_WarnAlternativeLayoutRuleTransitional,
- warnSpec Opt_WarnAmbiguousFields,
- depWarnSpec Opt_WarnAutoOrphans
- "it has no effect",
- warnSpec Opt_WarnCPPUndef,
- warnSpec Opt_WarnUnbangedStrictPatterns,
- warnSpec Opt_WarnDeferredTypeErrors,
- warnSpec Opt_WarnDeferredOutOfScopeVariables,
- warnSpec Opt_WarnDeprecatedFlags,
- warnSpec Opt_WarnDerivingDefaults,
- warnSpec Opt_WarnDerivingTypeable,
- warnSpec Opt_WarnDodgyExports,
- warnSpec Opt_WarnDodgyForeignImports,
- warnSpec Opt_WarnDodgyImports,
- warnSpec Opt_WarnEmptyEnumerations,
- subWarnSpec "duplicate-constraints"
- Opt_WarnDuplicateConstraints
- "it is subsumed by -Wredundant-constraints",
- warnSpec Opt_WarnRedundantConstraints,
- warnSpec Opt_WarnDuplicateExports,
- depWarnSpec Opt_WarnHiShadows
- "it is not used, and was never implemented",
- warnSpec Opt_WarnInaccessibleCode,
- warnSpec Opt_WarnImplicitPrelude,
- depWarnSpec Opt_WarnImplicitKindVars
- "it is now an error",
- warnSpec Opt_WarnIncompletePatterns,
- warnSpec Opt_WarnIncompletePatternsRecUpd,
- warnSpec Opt_WarnIncompleteUniPatterns,
- warnSpec Opt_WarnInlineRuleShadowing,
- warnSpec Opt_WarnIdentities,
- warnSpec Opt_WarnMissingFields,
- warnSpec Opt_WarnMissingImportList,
- warnSpec Opt_WarnMissingExportList,
- subWarnSpec "missing-local-sigs"
- Opt_WarnMissingLocalSignatures
- "it is replaced by -Wmissing-local-signatures",
- warnSpec Opt_WarnMissingLocalSignatures,
- warnSpec Opt_WarnMissingMethods,
- depWarnSpec Opt_WarnMissingMonadFailInstances
- "fail is no longer a method of Monad",
- warnSpec Opt_WarnSemigroup,
- warnSpec Opt_WarnMissingSignatures,
- warnSpec Opt_WarnMissingKindSignatures,
- warnSpec Opt_WarnMissingPolyKindSignatures,
- subWarnSpec "missing-exported-sigs"
- Opt_WarnMissingExportedSignatures
- "it is replaced by -Wmissing-exported-signatures",
- warnSpec Opt_WarnMissingExportedSignatures,
- warnSpec Opt_WarnMonomorphism,
- warnSpec Opt_WarnNameShadowing,
- warnSpec Opt_WarnNonCanonicalMonadInstances,
- depWarnSpec Opt_WarnNonCanonicalMonadFailInstances
- "fail is no longer a method of Monad",
- warnSpec Opt_WarnNonCanonicalMonoidInstances,
- warnSpec Opt_WarnOrphans,
- warnSpec Opt_WarnOverflowedLiterals,
- warnSpec Opt_WarnOverlappingPatterns,
- warnSpec Opt_WarnMissedSpecs,
- warnSpec Opt_WarnAllMissedSpecs,
- warnSpec' Opt_WarnSafe setWarnSafe,
- warnSpec Opt_WarnTrustworthySafe,
- warnSpec Opt_WarnInferredSafeImports,
- warnSpec Opt_WarnMissingSafeHaskellMode,
- warnSpec Opt_WarnTabs,
- warnSpec Opt_WarnTypeDefaults,
- warnSpec Opt_WarnTypedHoles,
- warnSpec Opt_WarnPartialTypeSignatures,
- warnSpec Opt_WarnUnrecognisedPragmas,
- warnSpec Opt_WarnMisplacedPragmas,
- warnSpec' Opt_WarnUnsafe setWarnUnsafe,
- warnSpec Opt_WarnUnsupportedCallingConventions,
- warnSpec Opt_WarnUnsupportedLlvmVersion,
- warnSpec Opt_WarnMissedExtraSharedLib,
- warnSpec Opt_WarnUntickedPromotedConstructors,
- warnSpec Opt_WarnUnusedDoBind,
- warnSpec Opt_WarnUnusedForalls,
- warnSpec Opt_WarnUnusedImports,
- warnSpec Opt_WarnUnusedLocalBinds,
- warnSpec Opt_WarnUnusedMatches,
- warnSpec Opt_WarnUnusedPatternBinds,
- warnSpec Opt_WarnUnusedTopBinds,
- warnSpec Opt_WarnUnusedTypePatterns,
- warnSpec Opt_WarnUnusedRecordWildcards,
- warnSpec Opt_WarnRedundantBangPatterns,
- warnSpec Opt_WarnRedundantRecordWildcards,
- warnSpec Opt_WarnRedundantStrictnessFlags,
- warnSpec Opt_WarnWrongDoBind,
- warnSpec Opt_WarnMissingPatternSynonymSignatures,
- warnSpec Opt_WarnMissingDerivingStrategies,
- warnSpec Opt_WarnSimplifiableClassConstraints,
- warnSpec Opt_WarnMissingHomeModules,
- warnSpec Opt_WarnUnrecognisedWarningFlags,
- warnSpec Opt_WarnStarBinder,
- warnSpec Opt_WarnStarIsType,
- depWarnSpec Opt_WarnSpaceAfterBang
- "bang patterns can no longer be written with a space",
- warnSpec Opt_WarnPartialFields,
- warnSpec Opt_WarnPrepositiveQualifiedModule,
- warnSpec Opt_WarnUnusedPackages,
- warnSpec Opt_WarnCompatUnqualifiedImports,
- warnSpec Opt_WarnInvalidHaddock,
- warnSpec Opt_WarnOperatorWhitespaceExtConflict,
- warnSpec Opt_WarnOperatorWhitespace,
- warnSpec Opt_WarnImplicitLift,
- warnSpec Opt_WarnMissingExportedPatternSynonymSignatures,
- warnSpec Opt_WarnForallIdentifier,
- warnSpec Opt_WarnUnicodeBidirectionalFormatCharacters,
- warnSpec Opt_WarnGADTMonoLocalBinds,
- warnSpec Opt_WarnTypeEqualityOutOfScope,
- warnSpec Opt_WarnTypeEqualityRequiresOperators,
- warnSpec Opt_WarnTermVariableCapture,
- warnSpec Opt_WarnMissingRoleAnnotations,
- warnSpec Opt_WarnImplicitRhsQuantification,
- warnSpec Opt_WarnIncompleteExportWarnings,
- warnSpec Opt_WarnIncompleteRecordSelectors
- ]
+ Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x
+ Opt_WarnAmbiguousFields -> warnSpec x
+ Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"
+ Opt_WarnCPPUndef -> warnSpec x
+ Opt_WarnBadlyStagedTypes -> warnSpec x
+ Opt_WarnUnbangedStrictPatterns -> warnSpec x
+ Opt_WarnDeferredTypeErrors -> warnSpec x
+ Opt_WarnDeferredOutOfScopeVariables -> warnSpec x
+ Opt_WarnDeprecatedFlags -> warnSpec x
+ Opt_WarnDerivingDefaults -> warnSpec x
+ Opt_WarnDerivingTypeable -> warnSpec x
+ Opt_WarnDodgyExports -> warnSpec x
+ Opt_WarnDodgyForeignImports -> warnSpec x
+ Opt_WarnDodgyImports -> warnSpec x
+ Opt_WarnEmptyEnumerations -> warnSpec x
+ Opt_WarnDuplicateConstraints
+ -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"
+ Opt_WarnRedundantConstraints -> warnSpec x
+ Opt_WarnDuplicateExports -> warnSpec x
+ Opt_WarnHiShadows
+ -> depWarnSpec x "it is not used, and was never implemented"
+ Opt_WarnInaccessibleCode -> warnSpec x
+ Opt_WarnImplicitPrelude -> warnSpec x
+ Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error"
+ Opt_WarnIncompletePatterns -> warnSpec x
+ Opt_WarnIncompletePatternsRecUpd -> warnSpec x
+ Opt_WarnIncompleteUniPatterns -> warnSpec x
+ Opt_WarnInconsistentFlags -> warnSpec x
+ Opt_WarnInlineRuleShadowing -> warnSpec x
+ Opt_WarnIdentities -> warnSpec x
+ Opt_WarnLoopySuperclassSolve -> warnSpec x
+ Opt_WarnMissingFields -> warnSpec x
+ Opt_WarnMissingImportList -> warnSpec x
+ Opt_WarnMissingExportList -> warnSpec x
+ Opt_WarnMissingLocalSignatures
+ -> subWarnSpec "missing-local-sigs" x
+ "it is replaced by -Wmissing-local-signatures"
+ ++ warnSpec x
+ Opt_WarnMissingMethods -> warnSpec x
+ Opt_WarnMissingMonadFailInstances
+ -> depWarnSpec x "fail is no longer a method of Monad"
+ Opt_WarnSemigroup -> warnSpec x
+ Opt_WarnMissingSignatures -> warnSpec x
+ Opt_WarnMissingKindSignatures -> warnSpec x
+ Opt_WarnMissingPolyKindSignatures -> warnSpec x
+ Opt_WarnMissingExportedSignatures
+ -> subWarnSpec "missing-exported-sigs" x
+ "it is replaced by -Wmissing-exported-signatures"
+ ++ warnSpec x
+ Opt_WarnMonomorphism -> warnSpec x
+ Opt_WarnNameShadowing -> warnSpec x
+ Opt_WarnNonCanonicalMonadInstances -> warnSpec x
+ Opt_WarnNonCanonicalMonadFailInstances
+ -> depWarnSpec x "fail is no longer a method of Monad"
+ Opt_WarnNonCanonicalMonoidInstances -> warnSpec x
+ Opt_WarnOrphans -> warnSpec x
+ Opt_WarnOverflowedLiterals -> warnSpec x
+ Opt_WarnOverlappingPatterns -> warnSpec x
+ Opt_WarnMissedSpecs -> warnSpec x
+ Opt_WarnAllMissedSpecs -> warnSpec x
+ Opt_WarnSafe -> warnSpec' x setWarnSafe
+ Opt_WarnTrustworthySafe -> warnSpec x
+ Opt_WarnInferredSafeImports -> warnSpec x
+ Opt_WarnMissingSafeHaskellMode -> warnSpec x
+ Opt_WarnTabs -> warnSpec x
+ Opt_WarnTypeDefaults -> warnSpec x
+ Opt_WarnTypedHoles -> warnSpec x
+ Opt_WarnPartialTypeSignatures -> warnSpec x
+ Opt_WarnUnrecognisedPragmas -> warnSpec x
+ Opt_WarnMisplacedPragmas -> warnSpec x
+ Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe
+ Opt_WarnUnsupportedCallingConventions -> warnSpec x
+ Opt_WarnUnsupportedLlvmVersion -> warnSpec x
+ Opt_WarnMissedExtraSharedLib -> warnSpec x
+ Opt_WarnUntickedPromotedConstructors -> warnSpec x
+ Opt_WarnUnusedDoBind -> warnSpec x
+ Opt_WarnUnusedForalls -> warnSpec x
+ Opt_WarnUnusedImports -> warnSpec x
+ Opt_WarnUnusedLocalBinds -> warnSpec x
+ Opt_WarnUnusedMatches -> warnSpec x
+ Opt_WarnUnusedPatternBinds -> warnSpec x
+ Opt_WarnUnusedTopBinds -> warnSpec x
+ Opt_WarnUnusedTypePatterns -> warnSpec x
+ Opt_WarnUnusedRecordWildcards -> warnSpec x
+ Opt_WarnRedundantBangPatterns -> warnSpec x
+ Opt_WarnRedundantRecordWildcards -> warnSpec x
+ Opt_WarnRedundantStrictnessFlags -> warnSpec x
+ Opt_WarnWrongDoBind -> warnSpec x
+ Opt_WarnMissingPatternSynonymSignatures -> warnSpec x
+ Opt_WarnMissingDerivingStrategies -> warnSpec x
+ Opt_WarnSimplifiableClassConstraints -> warnSpec x
+ Opt_WarnMissingHomeModules -> warnSpec x
+ Opt_WarnUnrecognisedWarningFlags -> warnSpec x
+ Opt_WarnStarBinder -> warnSpec x
+ Opt_WarnStarIsType -> warnSpec x
+ Opt_WarnSpaceAfterBang
+ -> depWarnSpec x "bang patterns can no longer be written with a space"
+ Opt_WarnPartialFields -> warnSpec x
+ Opt_WarnPrepositiveQualifiedModule -> warnSpec x
+ Opt_WarnUnusedPackages -> warnSpec x
+ Opt_WarnCompatUnqualifiedImports -> warnSpec x
+ Opt_WarnInvalidHaddock -> warnSpec x
+ Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x
+ Opt_WarnOperatorWhitespace -> warnSpec x
+ Opt_WarnImplicitLift -> warnSpec x
+ Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x
+ Opt_WarnForallIdentifier -> warnSpec x
+ Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x
+ Opt_WarnGADTMonoLocalBinds -> warnSpec x
+ Opt_WarnTypeEqualityOutOfScope -> warnSpec x
+ Opt_WarnTypeEqualityRequiresOperators -> warnSpec x
+ Opt_WarnTermVariableCapture -> warnSpec x
+ Opt_WarnMissingRoleAnnotations -> warnSpec x
+ Opt_WarnImplicitRhsQuantification -> warnSpec x
+ Opt_WarnIncompleteExportWarnings -> warnSpec x
+ Opt_WarnIncompleteRecordSelectors -> warnSpec x
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
warningGroupsDeps = map mk warningGroups
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -149,7 +149,8 @@ instance Uniquable Module where
instance Binary a => Binary (GenModule a) where
put_ bh (Module p n) = put_ bh p >> put_ bh n
- get bh = do p <- get bh; n <- get bh; return (Module p n)
+ -- Module has strict fields, so use $! in order not to allocate a thunk
+ get bh = do p <- get bh; n <- get bh; return $! Module p n
instance NFData (GenModule a) where
rnf (Module unit name) = unit `seq` name `seq` ()
@@ -317,13 +318,14 @@ instance Binary InstantiatedUnit where
cid <- get bh
insts <- get bh
let fs = mkInstantiatedUnitHash cid insts
- return InstantiatedUnit {
- instUnitInstanceOf = cid,
- instUnitInsts = insts,
- instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
- instUnitFS = fs,
- instUnitKey = getUnique fs
- }
+ -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk
+ return $! InstantiatedUnit {
+ instUnitInstanceOf = cid,
+ instUnitInsts = insts,
+ instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ instUnitFS = fs,
+ instUnitKey = getUnique fs
+ }
instance IsUnitId u => Eq (GenUnit u) where
uid1 == uid2 = unitUnique uid1 == unitUnique uid2
@@ -369,10 +371,12 @@ instance Binary Unit where
put_ bh HoleUnit =
putByte bh 2
get bh = do b <- getByte bh
- case b of
+ u <- case b of
0 -> fmap RealUnit (get bh)
1 -> fmap VirtUnit (get bh)
_ -> pure HoleUnit
+ -- Unit has strict fields that need forcing; otherwise we allocate a thunk.
+ pure $! u
-- | Retrieve the set of free module holes of a 'Unit'.
unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e37a1a3cdfaa6b44888b18526c5e1567fddf7733...60ce84eb9e1ff7abb8c2ee4d67eb958581fc8dff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e37a1a3cdfaa6b44888b18526c5e1567fddf7733...60ce84eb9e1ff7abb8c2ee4d67eb958581fc8dff
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/20231010/cf16127a/attachment-0001.html>
More information about the ghc-commits
mailing list