[Git][ghc/ghc][wip/generic-length] perf: Replace uses of genericLength with strictGenericLength
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Jan 31 14:49:49 UTC 2025
Matthew Pickering pushed to branch wip/generic-length at Glasgow Haskell Compiler / GHC
Commits:
a75c70e4 by Matthew Pickering at 2025-01-31T14:49:26+00:00
perf: Replace uses of genericLength with strictGenericLength
genericLength is a recursive function and marked NOINLINE. It is not
going to specialise. In profiles, it can be seen that 3% of total compilation
time when computing bytecode is spend calling this non-specialised
function.
In addition, we can simplify `addListToSS` to avoid traversing the input
list twice and also allocating an intermediate list (after the call to
reverse).
Overall these changes reduce the time spend in 'assembleBCOs' from 5.61s
to 3.88s. Allocations drop from 8GB to 5.3G.
Fixes #25706
- - - - -
4 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghc-boot/GHC/Data/SizedSeq.hs
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -53,7 +53,6 @@ import Data.Array.Base ( UArray(..) )
import Foreign hiding (shiftL, shiftR)
import Data.Char ( ord )
-import Data.List ( genericLength )
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
@@ -343,6 +342,7 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
+
inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
@@ -350,7 +350,7 @@ inspectAsm platform long_jumps initial_offset
go s (NullAsm _) = (instrCount s, lblEnv s)
go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
where n = ptrCount s
- go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
+ go s (AllocLit ls k) = go (s { litCount = n + strictGenericLength ls }) (k n)
where n = litCount s
go s (AllocLabel lbl k) = go s' k
where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -25,6 +25,8 @@ module GHC.Prelude.Basic
, shiftL, shiftR
, setBit, clearBit
, head, tail
+
+ , strictGenericLength
) where
@@ -130,3 +132,18 @@ head = Prelude.head
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+
+{- |
+The 'genericLength' function defined in base can't be specialised due to the
+NOINLINE pragma.
+
+It is also not strict in the accumulator, and strictGenericLength is not exported.
+
+See #25706 for why it is important to use a strict, specialised version.
+
+-}
+strictGenericLength :: Num a => [x] -> a
+strictGenericLength = foldl' (\n _ -> 1 + n) 0
+{-# INLINABLE strictGenericLength #-}
+
+{-# SPECIALISE strictGenericLength :: forall x . [x] -> Word #-}
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -70,7 +70,7 @@ import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import GHC.Types.SptEntry
-import Data.List ( genericReplicate, genericLength, intersperse
+import Data.List ( genericReplicate, intersperse
, partition, scanl', sortBy, zip4, zip6 )
import Foreign hiding (shiftL, shiftR)
import Control.Monad
@@ -393,7 +393,7 @@ schemeR_wrk fvs nm original_body (args, body)
-- make the arg bitmap
bits = argBits platform (reverse (map (idArgRep platform) all_args))
- bitmap_size = genericLength bits
+ bitmap_size = strictGenericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -607,7 +607,7 @@ schemeE d s p (StgLet _ext binds body) = do
platform <- targetPlatform <$> getDynFlags
let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
StgRec xs_n_rhss -> unzip xs_n_rhss
- n_binds = genericLength xs
+ n_binds = strictGenericLength xs
fvss = map (fvsToEnv p') rhss
@@ -616,7 +616,7 @@ schemeE d s p (StgLet _ext binds body) = do
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss
+ arities = map (strictGenericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1 word. d' and p' reflect the stack
@@ -1857,7 +1857,7 @@ implement_tagToId
implement_tagToId d s p arg names
= assert (notNull names) $
do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
- labels <- getLabelsBc (genericLength names)
+ labels <- getLabelsBc (strictGenericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
dflags <- getDynFlags
=====================================
libraries/ghc-boot/GHC/Data/SizedSeq.hs
=====================================
@@ -11,7 +11,6 @@ module GHC.Data.SizedSeq
import Prelude -- See note [Why do we import Prelude here?]
import Control.DeepSeq
import Data.Binary
-import Data.List (genericLength)
import GHC.Generics
data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]
@@ -37,9 +36,9 @@ emptySS = SizedSeq 0 []
addToSS :: SizedSeq a -> a -> SizedSeq a
addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
+-- NB, important this is eta-expand so that foldl' is inlined.
addListToSS :: SizedSeq a -> [a] -> SizedSeq a
-addListToSS (SizedSeq n r_xs) xs
- = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
+addListToSS s xs = foldl' addToSS s xs
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a75c70e400751f54d76e4c6dd304cc5a76d1e0c2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a75c70e400751f54d76e4c6dd304cc5a76d1e0c2
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/20250131/274ac9fd/attachment-0001.html>
More information about the ghc-commits
mailing list