From cdfe6e01f113dbed9df6703c97207c02fc60303b Mon Sep 17 00:00:00 2001
From: Fendor <fendor@posteo.de>
Date: Tue, 19 Mar 2024 10:12:15 +0100
Subject: [PATCH] Compact serialisation of IfaceAppArgs
In #24563, we identified that IfaceAppArgs serialisation tags each
cons cell element with a discriminator byte. These bytes add up
quickly, blowing up interface files considerably when
'-fwrite-if-simplified-core' is enabled.
We compact the serialisation by writing out the length of
'IfaceAppArgs', followed by serialising the elements directly without
any discriminator byte.
This improvement can decrease the size of some interface files by up
to 35%.
---
compiler/GHC/Iface/Type.hs | 40 +++++++++++++++++++++++++-------------
1 file changed, 26 insertions(+), 14 deletions(-)
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 1555f725a61..ea024734fcc 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -728,6 +728,12 @@ ifaceVisAppArgsLength = go 0
| isVisibleForAllTyFlag argf = go (n+1) rest
| otherwise = go n rest
+ifaceAppArgsLength :: IfaceAppArgs -> Int
+ifaceAppArgsLength = go 0
+ where
+ go !n IA_Nil = n
+ go !n (IA_Arg _ _ ts) = go (n + 1) ts
+
{-
Note [Suppressing invisible arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2090,21 +2096,27 @@ instance Binary IfaceTyLit where
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceAppArgs where
- put_ bh tk =
- case tk of
- IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts
- IA_Nil -> putByte bh 1
+ put_ bh tk = do
+ -- Int is variable length encoded so only
+ -- one byte for small lists.
+ put_ bh (ifaceAppArgsLength tk)
+ go tk
+ where
+ go IA_Nil = pure ()
+ go (IA_Arg a b t) = do
+ put_ bh a
+ put_ bh b
+ go t
- get bh =
- do c <- getByte bh
- case c of
- 0 -> do
- t <- get bh
- a <- get bh
- ts <- get bh
- return $! IA_Arg t a ts
- 1 -> return IA_Nil
- _ -> panic ("get IfaceAppArgs " ++ show c)
+ get bh = do
+ n <- get bh :: IO Int
+ go n
+ where
+ go 0 = return IA_Nil
+ go c = do
+ a <- get bh
+ b <- get bh
+ IA_Arg a b <$> go (c - 1)
-------------------
--
GitLab