[Git][ghc/ghc][wip/T23964] Stricter Binary.get in GHC.Types.Unit (#23964)

[Sebastian Graf (@sgraf812)]

Sebastian Graf pushed to branch wip/T23964 at Glasgow Haskell Compiler / GHC


Commits:
d1177220 by Sebastian Graf at 2023-10-02T11:13:05+02: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.

- - - - -


1 changed file:

- compiler/GHC/Unit/Types.hs


Changes:

=====================================
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/-/commit/d1177220330a2432190d55f4f0c037f41c871ee6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1177220330a2432190d55f4f0c037f41c871ee6
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/20231002/cb5956a9/attachment-0001.html>