diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-03-29 15:03:11 +0100 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-04-07 09:38:49 +0100 |
| commit | bf37cf51311f4f1b8770033d0094cbd98ef76897 (patch) | |
| tree | 079c0a36c6a14f2ab066dabf3c73dbc2717baaa7 | |
| parent | 57eec789d98580bd866bbc0121dd75561f00b2ca (diff) | |
| download | haskell-bf37cf51311f4f1b8770033d0094cbd98ef76897.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: |