[Git][ghc/ghc][master] perf: Replace uses of genericLength with strictGenericLength

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
db19c8a9 by Matthew Pickering at 2025-02-05T23:16:50-05: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
=====================================
@@ -52,7 +52,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
@@ -333,6 +332,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)
@@ -340,7 +340,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,15 @@ 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 = fromIntegral . length


=====================================
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
@@ -394,7 +394,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
 
@@ -608,7 +608,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
 
@@ -617,7 +617,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
@@ -1858,7 +1858,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
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-}
 module GHC.Data.SizedSeq
   ( SizedSeq(..)
   , emptySS
@@ -11,9 +11,12 @@ 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
 
+#if ! MIN_VERSION_base(4,20,0)
+import Data.List (foldl')
+#endif
+
 data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]
   deriving (Generic, Show)
 
@@ -37,9 +40,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/db19c8a95a187fa6fcfbcc9c96961044786cc945

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db19c8a95a187fa6fcfbcc9c96961044786cc945
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/20250205/98bf4346/attachment-0001.html>