diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-03-29 15:03:11 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-04-08 08:07:11 -0400 |
| commit | 629a5e98b72e1643ef8eeabb700a7046a27a783a (patch) | |
| tree | 89afabab515d7dd2174ea883803140e03f55f73e | |
| parent | eaa1461a70c5ce45e496c459bfcdcdef1b4313bb (diff) | |
| download | haskell-629a5e98b72e1643ef8eeabb700a7046a27a783a.tar.gz | |
Some extra strictness in Demand.hs
It seems that these places were supposed to be forced anyway but the
forcing has no effect because the result was immediately placed in a
lazy box.
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Misc.hs | 12 |
2 files changed, 13 insertions, 3 deletions
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index a75c786bfb..b4d9aa9384 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -357,7 +357,7 @@ viewProd :: Arity -> SubDemand -> Maybe [Demand] viewProd n (Prod ds) | ds `lengthIs` n = Just ds -- Note the strict application to replicate: This makes sure we don't allocate -- a thunk for it, inlines it and lets case-of-case fire at call sites. -viewProd n (Poly card) = Just (replicate n $! polyDmd card) +viewProd n (Poly card) = Just $! (replicate n $! polyDmd card) viewProd _ _ = Nothing {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation -- for Arity. Otherwise, #18304 bites us. @@ -386,7 +386,7 @@ seqDmd = C_11 :* seqSubDmd lubSubDmd :: SubDemand -> SubDemand -> SubDemand -- Handle Prod lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) = - Prod $ zipWith lubDmd ds2 ds1 -- try to fuse with ds2 + Prod $ strictZipWith lubDmd ds2 ds1 -- try to fuse with ds2 -- Handle Call lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2)) -- See Note [Call demands are relative] diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 96dce36f94..3c31f32d42 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -85,7 +85,7 @@ module GHC.Utils.Misc ( transitiveClosure, -- * Strictness - seqList, strictMap, + seqList, strictMap, strictZipWith, -- * Module names looksLikeModuleName, @@ -1078,6 +1078,16 @@ strictMap f (x : xs) = in x' : xs' +strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c] +strictZipWith _ [] _ = [] +strictZipWith _ _ [] = [] +strictZipWith f (x : xs) (y: ys) = + let + !x' = f x y + !xs' = strictZipWith f xs ys + in + x' : xs' + -- Module names: |