[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Stricter Binary.get in GHC.Types.Unit (#23964)

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Oct 10 11:19:27 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
e7cfe4a8 by Sebastian Graf at 2023-10-10T07:19:09-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.

- - - - -
bc6a8975 by Bryan Richter at 2023-10-10T07:19:09-04:00
rel_eng/upload.sh cleanups

- - - - -
94eeb16a by doyougnu at 2023-10-10T07:19:12-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.

- - - - -
265e36bf by Matthew Craven at 2023-10-10T07:19:12-04:00
Make 'wWarningFlagsDeps' include every WarningFlag

Fixes #24071.

- - - - -


6 changed files:

- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/upload.sh
- 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"
       }
     ],


=====================================
.gitlab/rel_eng/upload.sh
=====================================
@@ -1,6 +1,7 @@
-#!/usr/bin/env bash
+#!/usr/bin/env nix-shell
+#! nix-shell -i bash -p moreutils lzip zip lftp gnupg
 
-set -e
+set -Eeuo pipefail
 
 # This is a script for preparing and uploading a release of GHC.
 #
@@ -30,21 +31,15 @@ set -e
 #
 # Prerequisites: moreutils
 
-if [ -z "$SIGNING_KEY" ]; then
-    SIGNING_KEY="=Benjamin Gamari <ben at well-typed.com>"
-fi
+: ${SIGNING_KEY:="=Benjamin Gamari <ben at well-typed.com>"}
 
 
 # Infer release name from directory name
-if [ -z "$rel_name" ]; then
-    rel_name="$(basename $(pwd))"
-fi
+: ${rel_name:=$(basename $(pwd))}
 
 # Infer version from tarball names
-if [ -z "$ver" ]; then
-    ver="$(ls ghc-*.tar.* | sed -ne 's/ghc-\([0-9]\+\.[0-9]\+\.[0-9]\+\(\.[0-9]\+\)\?\).\+/\1/p' | head -n1)"
-    if [ -z "$ver" ]; then echo "Failed to infer \$ver"; exit 1; fi
-fi
+: ${ver:=$(ls ghc-*.tar.* | sed -ne 's/ghc-\([0-9]\+\.[0-9]\+\.[0-9]\+\(\.[0-9]\+\)\?\).\+/\1/p' | head -n1)}
+if [ -z "$ver" ]; then echo "Failed to infer \$ver"; exit 1; fi
 
 host="gitlab-storage.haskell.org"
 
@@ -141,6 +136,7 @@ function upload() {
 }
 
 function purge_all() {
+    dir="$(echo $rel_name | sed s/-release//)"
     # Purge CDN cache
     curl -X PURGE http://downloads.haskell.org/ghc/
     curl -X PURGE http://downloads.haskell.org/~ghc/
@@ -196,6 +192,7 @@ function prepare_docs() {
 }
 
 function recompress() {
+    set -Eeuo pipefail
     combine <(basename -s .xz *.xz) not <(basename -s .lz *.lz) | \
         parallel 'echo "Recompressing {}.xz to {}.lz"; unxz -c {}.xz | lzip - -o {}.lz'
 


=====================================
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/60ce84eb9e1ff7abb8c2ee4d67eb958581fc8dff...265e36bf780ae0cb3b2214f699d51af124e82a8e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/60ce84eb9e1ff7abb8c2ee4d67eb958581fc8dff...265e36bf780ae0cb3b2214f699d51af124e82a8e
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/27119760/attachment-0001.html>


More information about the ghc-commits mailing list