[Git][ghc/ghc][master] Avoid iterating twice in `zipTyEnv` (#18535)

[Marge Bot]

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


Commits:
2157be52 by theobat at 2020-09-12T21:27:04-04:00
Avoid iterating twice in `zipTyEnv` (#18535)

zipToUFM is a new function to replace `listToUFM (zipEqual ks vs)`.
An explicit recursion is preferred due to the sensible nature of fusion.

    T12227 -6.0%
    T12545 -12.3%
    T5030  -9.0%
    T9872a -1.6%
    T9872b -1.6%
    T9872c -2.0%

 -------------------------
Metric Decrease:
    T12227
    T12545
    T5030
    T9872a
    T9872b
    T9872c
-------------------------

- - - - -


2 changed files:

- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Types/Unique/FM.hs


Changes:

=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -440,7 +440,7 @@ zipTyEnv tyvars tys
   = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys)
   | otherwise
   = ASSERT( all (not . isCoercionTy) tys )
-    mkVarEnv (zipEqual "zipTyEnv" tyvars tys)
+    zipToUFM tyvars tys
         -- There used to be a special case for when
         --      ty == TyVarTy tv
         -- (a not-uncommon case) in which case the substitution was dropped.


=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -23,6 +23,7 @@ of arguments of combining function.
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -Wall #-}
 
 module GHC.Types.Unique.FM (
@@ -34,6 +35,7 @@ module GHC.Types.Unique.FM (
         emptyUFM,
         unitUFM,
         unitDirectlyUFM,
+        zipToUFM,
         listToUFM,
         listToUFM_Directly,
         listToUFM_C,
@@ -75,11 +77,14 @@ module GHC.Types.Unique.FM (
         pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
     ) where
 
+#include "HsVersions.h"
+
 import GHC.Prelude
 
 import GHC.Types.Unique ( Uniquable(..), Unique, getKey )
 import GHC.Utils.Outputable
-
+import GHC.Utils.Panic (assertPanic)
+import GHC.Utils.Misc (debugIsOn)
 import qualified Data.IntMap as M
 import qualified Data.IntSet as S
 import Data.Data
@@ -113,6 +118,19 @@ unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
 unitDirectlyUFM :: Unique -> elt -> UniqFM key elt
 unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
 
+-- zipToUFM ks vs = listToUFM (zip ks vs)
+-- This function exists because it's a common case (#18535), and
+-- it's inefficient to first build a list of pairs, and then immediately
+-- take it apart. Astonishingly, fusing this one list away reduces total
+-- compiler allocation by more than 10% (in T12545, see !3935)
+-- Note that listToUFM (zip ks vs) performs similarly, but
+-- the explicit recursion avoids relying too much on fusion.
+zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt
+zipToUFM ks vs = ASSERT( length ks == length vs ) innerZip emptyUFM ks vs
+  where
+    innerZip ufm (k:kList) (v:vList) = innerZip (addToUFM ufm k v) kList vList
+    innerZip ufm _ _ = ufm
+
 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt
 listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2157be52cd454353582b04d89492b239b90f91f7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2157be52cd454353582b04d89492b239b90f91f7
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/20200912/793530ae/attachment-0001.html>