diff options
| author | theobat <theophile.batoz@gmail.com> | 2020-08-26 22:46:43 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-12 21:27:04 -0400 |
| commit | 2157be52cd454353582b04d89492b239b90f91f7 (patch) | |
| tree | 5d0dfaaa46480d0ae229ddaebdaa79f52b2f75a3 | |
| parent | 8440b5fa1397940f2f293935927e690b34110a73 (diff) | |
| download | haskell-2157be52cd454353582b04d89492b239b90f91f7.tar.gz | |
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
-------------------------
| -rw-r--r-- | compiler/GHC/Core/TyCo/Subst.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Types/Unique/FM.hs | 20 |
2 files changed, 20 insertions, 2 deletions
diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 3e8ef37bba..d85052700c 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/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. diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 41f3018a05..6d13436169 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/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 |