diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 25 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 512 |
2 files changed, 351 insertions, 186 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index bad3234ca9..5f209701a9 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -43,7 +43,8 @@ import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set --- import GHC.Driver.Ppr +import GHC.Utils.Trace +_ = pprTrace -- Tired of commenting out the import all the time {- ************************************************************************ @@ -340,11 +341,12 @@ dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr -- Should obey the let/app invariant -> (PlusDmdArg, CoreExpr) -dmdAnalStar env (n :* cd) e - | WithDmdType dmd_ty e' <- dmdAnal env cd e +dmdAnalStar env (n :* sd) e + -- NB: (:*) expands AbsDmd and BotDmd as needed + -- See Note [Analysing with absent demand] + | WithDmdType dmd_ty e' <- dmdAnal env sd e = assertPpr (not (isUnliftedType (exprType e)) || exprOkForSpeculation e) (ppr e) -- The argument 'e' should satisfy the let/app invariant - -- See Note [Analysing with absent demand] in GHC.Types.Demand (toPlusDmdArg $ multDmdType n dmd_ty, e') -- Main Demand Analsysis machinery @@ -427,7 +429,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! - (_ :* case_bndr_sd) = case_bndr_dmd + (_ :* case_bndr_sd) = case_bndr_dmd -- Compute demand on the scrutinee -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv @@ -548,7 +550,7 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on scrutinee of a product case] - id_dmds = addCaseBndrDmd case_bndr_sd dmds + id_dmds = addCaseBndrDmd case_bndr_sd dmds -- Do not put a thunk into the Alt !new_ids = setBndrsDemandInfo bndrs id_dmds = WithDmdType alt_ty (Alt con new_ids rhs') @@ -557,7 +559,7 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we analyse an expression with demand A. The "A" means -"absent", so this expression will never be needed. What should happen? +"absent", so this expression will never be needed. What should happen? There are several wrinkles: * We *do* want to analyse the expression regardless. @@ -566,6 +568,15 @@ There are several wrinkles: But we can post-process the results to ignore all the usage demands coming back. This is done by multDmdType. +* Nevertheless, which sub-demand should we pick for analysis? + Since the demand was absent, any would do. Worker/wrapper will replace + absent bindings with an absent filler anyway, so annotations in the RHS + of an absent binding don't matter much. + Picking 'botSubDmd' would be the most useful, but would also look a bit + misleading in the Core output of DmdAnal, because all nested annotations would + be bottoming. Better pick 'seqSubDmd', so that we annotate many of those + nested bindings with A themselves. + * In a previous incarnation of GHC we needed to be extra careful in the case of an *unlifted type*, because unlifted values are evaluated even if they are not used. Example (see #9254): diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index e8ea103705..4b9a04b9fb 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -1,5 +1,6 @@ - {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -15,7 +16,9 @@ -- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal". module GHC.Types.Demand ( -- * Demands - Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd, + Card(C_00, C_01, C_0N, C_10, C_11, C_1N), CardNonAbs, CardNonOnce, + Demand(AbsDmd, BotDmd, (:*)), + SubDemand(Prod), mkProd, viewProd, -- ** Algebra absDmd, topDmd, botDmd, seqDmd, topSubDmd, -- *** Least upper bound @@ -95,6 +98,12 @@ import GHC.Utils.Binary import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Panic.Plain + +import Data.Function + +import GHC.Utils.Trace +_ = pprTrace -- Tired of commenting out the import all the time {- ************************************************************************ @@ -106,17 +115,15 @@ import GHC.Utils.Panic {- Note [Evaluation cardinalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand analyser uses an /evaluation cardinality/ of type Card, -to specify how many times a term is evaluated. A cardinality C_lu -represents an /interval/ [l..u], meaning - C_lu means evaluated /at least/ 'l' times and - /at most/ 'u' times +The demand analyser uses an (abstraction of) /evaluation cardinality/ of type +Card, to specify how many times a term is evaluated. A Card C_lu +represents an /interval/ of possible cardinalities [l..u], meaning -* The lower bound corresponds to /strictness/ +* Evaluated /at least/ 'l' times (strictness). Hence 'l' is either 0 (lazy) or 1 (strict) -* The upper bound corresponds to /usage/ +* Evaluated /at most/ 'u' times (usage). Hence 'u' is either 0 (not used at all), or 1 (used at most once) or n (no information) @@ -127,42 +134,156 @@ Usually l<=u, but we also have C_10, the interval [1,0], the empty interval, denoting the empty set. This is the bottom element of the lattice. See Note [Demand notation] for the notation we use for each of the constructors. + +Note [Bit vector representation for Card] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While the 6 inhabitants of Card admit an efficient representation as an +enumeration, implementing operations such as lubCard, plusCard and multCard +leads to unreasonably bloated code. This was the old defn for lubCard, for +example: + + -- Handle C_10 (bot) + lubCard C_10 n = n -- bot + lubCard n C_10 = n -- bot + -- Handle C_0N (top) + lubCard C_0N _ = C_0N -- top + lubCard _ C_0N = C_0N -- top + -- Handle C_11 + lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1} + lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1} + lubCard C_11 n = n -- {1} is a subset of all other intervals + lubCard n C_11 = n -- {1} is a subset of all other intervals + -- Handle C_1N + lubCard C_1N C_1N = C_1N -- reflexivity + lubCard _ C_1N = C_0N -- {0} ∪ {1,n} = top + lubCard C_1N _ = C_0N -- {0} ∪ {1,n} = top + -- Handle C_01 + lubCard C_01 _ = C_01 -- {0} ∪ {0,1} = {0,1} + lubCard _ C_01 = C_01 -- {0} ∪ {0,1} = {0,1} + -- Handle C_00 + lubCard C_00 C_00 = C_00 -- reflexivity + +There's a much more compact way to encode these operations if Card is +represented not as distinctly denoted intervals, but as the subset of the set +of all cardinalities {0,1,n} instead. We represent such a subset as a bit vector +of length 3 (which fits in an Int). That's actually pretty common for such +powerset lattices. +There's one bit per denoted cardinality that is set iff that cardinality is part +of the denoted set, with n being the most significand bit (index 2) and 0 being +represented by the least significand bit (index 0). + +How does that help? Well, for one, lubCard just becomes + + lubCard (Card a) (Card b) = Card (a .|. b) + +The other operations, 'plusCard' and 'multCard', become significantly more +tricky, but immensely more compact. It's all straight-line code with a few bit +twiddling instructions now! + +Note [Algebraic specification for plusCard and multCard] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The representation change in Note [Bit vector representation for Card] admits +very dense definitions of 'plusCard' and 'multCard' in terms of bit twiddling, +but the connection to the algebraic operations they implement is lost. +It's helpful to have a written specification of what 'plusCard' and 'multCard' +here that says what they should compute. + + * plusCard: a@[l1,u1] + b@[l2,u2] = r@[l1+l2,u1+u2]. + - In terms of sets, 0 ∈ r iff 0 ∈ a and 0 ∈ b. + Examples: set in C_00 + C_00, C_01 + C_0N, but not in C_10 + C_00 + - In terms of sets, 1 ∈ r iff 1 ∈ a or 1 ∈ b. + Examples: set in C_01 + C_00, C_0N + C_0N, but not in C_10 + C_00 + - In terms of sets, n ∈ r iff n ∈ a or n ∈ b, or (1 ∈ a and 1 ∈ b), + so not unlike add with carry. + Examples: set in C_01 + C_01, C_01 + C_0N, but not in C_10 + C_01 + - Handy special cases: + o 'plusCard C_10' bumps up the strictness of its argument, just like + 'lubCard C_00' lazifies it, without touching upper bounds. + o Similarly, 'plusCard C_0N' discards usage information + (incl. absence) but leaves strictness alone. + + * multCard: a@[l1,u1] * b@[l2,u2] = r@[l1*l2,u1*u2]. + - In terms of sets, 0 ∈ r iff 0 ∈ a or 0 ∈ b. + Examples: set in C_00 * C_10, C_01 * C_1N, but not in C_10 * C_1N + - In terms of sets, 1 ∈ r iff 1 ∈ a and 1 ∈ b. + Examples: set in C_01 * C_01, C_01 * C_1N, but not in C_11 * C_10 + - In terms of sets, n ∈ r iff 1 ∈ r and (n ∈ a or n ∈ b). + Examples: set in C_1N * C_01, C_1N * C_0N, but not in C_10 * C_1N + - Handy special cases: + o 'multCard C_1N c' is the same as 'plusCard c c' and + drops used-once info. But unlike 'plusCard C_0N', it leaves absence + and strictness. + o 'multCard C_01' drops strictness info, like 'lubCard C_00'. + o 'multCard C_0N' does both; it discards all strictness and used-once + info and retains only absence info. -} -- | Describes an interval of /evaluation cardinalities/. -- See Note [Evaluation cardinalities] -data Card - = C_00 -- ^ {0} Absent. - | C_01 -- ^ {0,1} Used at most once. - | C_0N -- ^ {0,1,n} Every possible cardinality; the top element. - | C_11 -- ^ {1} Strict and used once. - | C_1N -- ^ {1,n} Strict and used (possibly) many times. - | C_10 -- ^ {} The empty interval; the bottom element of the lattice. +-- See Note [Bit vector representation for Card] +newtype Card = Card Int deriving Eq +-- | A subtype of 'Card' for which the upper bound is never 0 (no 'C_00' or +-- 'C_10'). The only four inhabitants are 'C_01', 'C_0N', 'C_11', 'C_1N'. +-- Membership can be tested with 'isCardNonAbs'. +-- See 'D' and 'Call' for use sites and explanation. +type CardNonAbs = Card + +-- | A subtype of 'Card' for which the upper bound is never 1 (no 'C_01' or +-- 'C_11'). The only four inhabitants are 'C_00', 'C_0N', 'C_10', 'C_1N'. +-- Membership can be tested with 'isCardNonOnce'. +-- See 'Poly' for use sites and explanation. +type CardNonOnce = Card + +-- | Absent, {0}. Pretty-printed as A. +pattern C_00 :: Card +pattern C_00 = Card 0b001 +-- | Bottom, {}. Pretty-printed as A. +pattern C_10 :: Card +pattern C_10 = Card 0b000 +-- | Strict and used once, {1}. Pretty-printed as 1. +pattern C_11 :: Card +pattern C_11 = Card 0b010 +-- | Used at most once, {0,1}. Pretty-printed as M. +pattern C_01 :: Card +pattern C_01 = Card 0b011 +-- | Strict and used (possibly) many times, {1,n}. Pretty-printed as S. +pattern C_1N :: Card +pattern C_1N = Card 0b110 +-- | Every possible cardinality; the top element, {0,1,n}. Pretty-printed as L. +pattern C_0N :: Card +pattern C_0N = Card 0b111 + +{-# COMPLETE C_00, C_01, C_0N, C_10, C_11, C_1N :: Card #-} + _botCard, topCard :: Card _botCard = C_10 topCard = C_0N -- | True <=> lower bound is 1. isStrict :: Card -> Bool -isStrict C_10 = True -isStrict C_11 = True -isStrict C_1N = True -isStrict _ = False +-- See Note [Bit vector representation for Card] +isStrict (Card c) = c .&. 0b001 == 0 -- simply check 0 bit is not set -- | True <=> upper bound is 0. isAbs :: Card -> Bool -isAbs C_00 = True -isAbs C_10 = True -- Bottom cardinality is also absent -isAbs _ = False +-- See Note [Bit vector representation for Card] +isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set -- | True <=> upper bound is 1. isUsedOnce :: Card -> Bool -isUsedOnce C_0N = False -isUsedOnce C_1N = False -isUsedOnce _ = True +-- See Note [Bit vector representation for Card] +isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set + +-- | Is this a 'CardNonAbs'? +isCardNonAbs :: Card -> Bool +isCardNonAbs = not . isAbs + +-- | Is this a 'CardNonOnce'? +isCardNonOnce :: Card -> Bool +isCardNonOnce n = isAbs n || not (isUsedOnce n) -- | Intersect with [0,1]. oneifyCard :: Card -> Card @@ -172,62 +293,28 @@ oneifyCard c = c -- | Denotes '∪' on 'Card'. lubCard :: Card -> Card -> Card --- Handle C_10 (bot) -lubCard C_10 n = n -- bot -lubCard n C_10 = n -- bot --- Handle C_0N (top) -lubCard C_0N _ = C_0N -- top -lubCard _ C_0N = C_0N -- top --- Handle C_11 -lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1} -lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1} -lubCard C_11 n = n -- {1} is a subset of all other intervals -lubCard n C_11 = n -- {1} is a subset of all other intervals --- Handle C_1N -lubCard C_1N C_1N = C_1N -- reflexivity -lubCard _ C_1N = C_0N -- {0} ∪ {1,n} = top -lubCard C_1N _ = C_0N -- {0} ∪ {1,n} = top --- Handle C_01 -lubCard C_01 _ = C_01 -- {0} ∪ {0,1} = {0,1} -lubCard _ C_01 = C_01 -- {0} ∪ {0,1} = {0,1} --- Handle C_00 -lubCard C_00 C_00 = C_00 -- reflexivity - --- | Denotes '+' on 'Card'. +-- See Note [Bit vector representation for Card] +lubCard (Card a) (Card b) = Card (a .|. b) -- main point of the bit-vector encoding! + +-- | Denotes '+' on lower and upper bounds of 'Card'. plusCard :: Card -> Card -> Card --- Handle C_00 -plusCard C_00 n = n -- {0}+n = n -plusCard n C_00 = n -- {0}+n = n --- Handle C_10 -plusCard C_10 C_01 = C_11 -- These follow by applying + to lower and upper -plusCard C_10 C_0N = C_1N -- bounds individually -plusCard C_10 n = n -plusCard C_01 C_10 = C_11 -plusCard C_0N C_10 = C_1N -plusCard n C_10 = n --- Handle the rest (C_01, C_0N, C_11, C_1N) -plusCard C_01 C_01 = C_0N -- The upper bound is at least 1, so upper bound of -plusCard C_01 C_0N = C_0N -- the result must be 1+1 ~= N. -plusCard C_0N C_01 = C_0N -- But for the lower bound we have 4 cases where -plusCard C_0N C_0N = C_0N -- 0+0 ~= 0 (as opposed to 1), so we match on these. -plusCard _ _ = C_1N -- Otherwise we return {1,n} - --- | Denotes '*' on 'Card'. +-- See Note [Algebraic specification for plusCard and multCard] +plusCard (Card a) (Card b) + = Card (bit0 .|. bit1 .|. bitN) + where + bit0 = (a .&. b) .&. 0b001 + bit1 = (a .|. b) .&. 0b010 + bitN = ((a .|. b) .|. shiftL (a .&. b) 1) .&. 0b100 + +-- | Denotes '*' on lower and upper bounds of 'Card'. multCard :: Card -> Card -> Card --- Handle C_11 (neutral element) -multCard C_11 c = c -multCard c C_11 = c --- Handle C_00 (annihilating element) -multCard C_00 _ = C_00 -multCard _ C_00 = C_00 --- Handle C_10 -multCard C_10 c = if isStrict c then C_10 else C_00 -multCard c C_10 = if isStrict c then C_10 else C_00 --- Handle reflexive C_1N, C_01 -multCard C_1N C_1N = C_1N -multCard C_01 C_01 = C_01 --- Handle C_0N and the rest (C_01, C_1N): -multCard _ _ = C_0N +-- See Note [Algebraic specification for plusCard and multCard] +multCard (Card a) (Card b) + = Card (bit0 .|. bit1 .|. bitN) + where + bit0 = (a .|. b) .&. 0b001 + bit1 = (a .&. b) .&. 0b010 + bitN = (a .|. b) .&. shiftL bit1 1 .&. 0b100 {- ************************************************************************ @@ -261,11 +348,47 @@ multCard _ _ = C_0N -- -- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of --- which could be used to infer uniqueness types. +-- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and +-- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there +-- isn't any evaluation at all. If you don't care, simply use '(:*)'. data Demand - = !Card :* !SubDemand + = BotDmd + -- ^ A bottoming demand, produced by a diverging function, hence there is no + -- 'SubDemand' that describes how it was evaluated. + | AbsDmd + -- ^ An absent demand: Evaluated exactly 0 times ('C_00'), hence there is no + -- 'SubDemand' that describes how it was evaluated. + | D !CardNonAbs !SubDemand + -- ^ Don't use this internal data constructor; use '(:*)' instead. deriving Eq +-- | Only meant to be used in the pattern synonym below! +viewDmdPair :: Demand -> (Card, SubDemand) +viewDmdPair BotDmd = (C_10, botSubDmd) +viewDmdPair AbsDmd = (C_00, seqSubDmd) +viewDmdPair (D n sd) = (n, sd) + +-- | @c :* sd@ is a demand that says \"evaluated @c@ times, and each time it +-- was evaluated, it was at least as deep as @sd@\". +-- +-- Matching on this pattern synonym is a complete match. +-- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@. +-- If the matched demand was 'BotDmd', it will match as @C_10 :* botSubDmd@. +-- The builder of this pattern synonym simply /discards/ the 'SubDemand' if the +-- 'Card' was absent and returns 'AbsDmd' or 'BotDmd' instead. It will assert +-- that the discarded sub-demand was 'seqSubDmd' and 'botSubDmd', respectively. +-- +-- Call sites should consider whether they really want to look at the +-- 'SubDemand' of an absent demand and match on 'AbsDmd' and/or 'BotDmd' +-- otherwise. Really, any other 'SubDemand' would be allowed and +-- might work better, depending on context. +pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand +pattern n :* sd <- (viewDmdPair -> (n, sd)) where + C_10 :* sd = BotDmd & assertPpr (sd == botSubDmd) (text "B /=" <+> ppr sd) + C_00 :* sd = AbsDmd & assertPpr (sd == seqSubDmd) (text "A /=" <+> ppr sd) + n :* sd = D n sd & assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) +{-# COMPLETE (:*) #-} + -- | A sub-demand describes an /evaluation context/, e.g. how deep the -- denoted thing is evaluated. See 'Demand' for examples. -- @@ -284,7 +407,7 @@ data Demand -- See Note [Call demands are relative] -- and Note [Demand notation]. data SubDemand - = Poly !Card + = Poly !CardNonOnce -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep, -- with the specified cardinality at every level. -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'. @@ -293,15 +416,17 @@ data SubDemand -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites. -- -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@, - -- @1 === P(1,1,...)@ and @1 === C1(1)@, and so on. + -- @B === P(B,B,...)@ and @B === CB(B)@, and so on. -- -- We only really use 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and - -- sometimes 'C_1N' (S), but it's simpler to treat it uniformly than to - -- have a special constructor for each of the three cases. - | Call !Card !SubDemand + -- sometimes 'C_1N' (S), hence 'CardNonOnce'. + | Call !CardNonAbs !SubDemand -- ^ @Call n sd@ describes the evaluation context of @n@ function -- applications, where every individual result is evaluated according to @sd@. - -- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative]. + -- @sd@ is /relative/ to a single call, see Note [Call demands are relative]. + -- That Note also explains why it doesn't make sense for @n@ to be absent, + -- hence we forbid it with 'CardNonAbs'. Absent call demands can still be + -- expressed with 'Poly'. -- Used only for values of function type. Use the smart constructor 'mkCall' -- whenever possible! | Prod ![Demand] @@ -310,25 +435,22 @@ data SubDemand -- evaluated according to @ds@. deriving Eq -poly00, poly01, poly0N, poly11, poly1N, poly10 :: SubDemand +poly00, poly0N, poly1N, poly10 :: SubDemand topSubDmd, botSubDmd, seqSubDmd :: SubDemand poly00 = Poly C_00 -poly01 = Poly C_01 poly0N = Poly C_0N -poly11 = Poly C_11 poly1N = Poly C_1N poly10 = Poly C_10 topSubDmd = poly0N botSubDmd = poly10 seqSubDmd = poly00 -polyDmd :: Card -> Demand -polyDmd C_00 = C_00 :* poly00 -polyDmd C_01 = C_01 :* poly01 +polyDmd :: CardNonOnce -> Demand +polyDmd C_00 = AbsDmd +polyDmd C_10 = BotDmd polyDmd C_0N = C_0N :* poly0N -polyDmd C_11 = C_11 :* poly11 polyDmd C_1N = C_1N :* poly1N -polyDmd C_10 = C_10 :* poly10 +polyDmd c = pprPanic "non-once Card" (ppr c) -- | A smart constructor for 'Prod', applying rewrite rules along the semantic -- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly' @@ -336,15 +458,12 @@ polyDmd C_10 = C_10 :* poly10 -- polymorphic demand will never unbox. mkProd :: [Demand] -> SubDemand mkProd [] = seqSubDmd -mkProd ds@(n:*sd : _) - | want_to_simplify n, all (== polyDmd n) ds = sd - | otherwise = Prod ds - where - -- We only want to simplify absent and bottom demands and unbox the others. - -- See also Note [L should win] and Note [Don't optimise LP(L,L,...) to L]. - want_to_simplify C_00 = True - want_to_simplify C_10 = True - want_to_simplify _ = False +-- We only want to simplify absent and bottom demands and unbox the others. +-- See also Note [L should win] and Note [Don't optimise LP(L,L,...) to L]. +mkProd ds + | all (== AbsDmd) ds = seqSubDmd + | all (== BotDmd) ds = botSubDmd + | otherwise = Prod ds -- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly' -- demands as necessary. @@ -363,37 +482,36 @@ viewProd _ _ = Nothing -- | A smart constructor for 'Call', applying rewrite rules along the semantic -- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's -- when possible. -mkCall :: Card -> SubDemand -> SubDemand -mkCall n cd@(Poly m) | n == m = cd -mkCall n cd = Call n cd - --- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as --- necessary. -viewCall :: SubDemand -> Maybe (Card, SubDemand) -viewCall (Call n sd) = Just (n, sd) -viewCall sd@(Poly card) = Just (card, sd) -viewCall _ = Nothing +mkCall :: CardNonAbs -> SubDemand -> SubDemand +mkCall C_1N sd@(Poly C_1N) = sd +mkCall C_0N sd@(Poly C_0N) = sd +mkCall n cd = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $ + Call n cd topDmd, absDmd, botDmd, seqDmd :: Demand topDmd = polyDmd C_0N -absDmd = polyDmd C_00 -botDmd = polyDmd C_10 +absDmd = AbsDmd +botDmd = BotDmd seqDmd = C_11 :* seqSubDmd -- | Denotes '∪' on 'SubDemand'. lubSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Handle botSubDmd (just an optimisation, the general case would do the same) +lubSubDmd (Poly C_10) d2 = d2 +lubSubDmd d1 (Poly C_10) = d1 -- Handle Prod -lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) = - Prod $ strictZipWith lubDmd ds2 ds1 -- try to fuse with ds2 +lubSubDmd (Prod ds1) (Poly n2) = Prod $ strictMap (lubDmd (polyDmd n2)) ds1 +lubSubDmd (Prod ds1) (Prod ds2) + | equalLength ds1 ds2 = Prod $ strictZipWith lubDmd ds1 ds2 -- Handle Call -lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2)) +lubSubDmd (Call n1 sd1) (Poly n2) -- See Note [Call demands are relative] - | isAbs n1 = mkCall (lubCard n1 n2) (lubSubDmd botSubDmd d2) - | isAbs n2 = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd) - | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2) --- Handle Poly + | isAbs n2 = mkCall (lubCard n2 n1) sd1 + | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 (Poly n2)) +lubSubDmd (Call n1 d1) (Call n2 d2) + | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2) +-- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again). lubSubDmd (Poly n1) (Poly n2) = Poly (lubCard n1 n2) --- Make use of reflexivity (so we'll match the Prod or Call cases again). lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 -- Otherwise (Call `lub` Prod) return Top lubSubDmd _ _ = topSubDmd @@ -404,50 +522,46 @@ lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2 -- | Denotes '+' on 'SubDemand'. plusSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Handle seqSubDmd (just an optimisation, the general case would do the same) +plusSubDmd (Poly C_00) d2 = d2 +plusSubDmd d1 (Poly C_00) = d1 -- Handle Prod -plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) = - Prod $ zipWith plusDmd ds2 ds1 -- try to fuse with ds2 +plusSubDmd (Prod ds1) (Poly n2) = Prod $ strictMap (plusDmd (polyDmd n2)) ds1 +plusSubDmd (Prod ds1) (Prod ds2) + | equalLength ds1 ds2 = Prod $ strictZipWith plusDmd ds1 ds2 -- Handle Call -plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2)) +plusSubDmd (Call n1 d1) (Poly n2) -- See Note [Call demands are relative] - | isAbs n1 = mkCall (plusCard n1 n2) (lubSubDmd botSubDmd d2) - | isAbs n2 = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd) - | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1 d2) --- Handle Poly + | isAbs n2 = mkCall (plusCard n2 n1) d1 + | otherwise = mkCall (plusCard n2 n1) (lubSubDmd d1 (Poly n2)) +plusSubDmd (Call n1 d1) (Call n2 d2) + | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1 d2) +-- Handle Poly. Exploit (so we'll match the Prod or Call cases again). plusSubDmd (Poly n1) (Poly n2) = Poly (plusCard n1 n2) --- Make use of reflexivity (so we'll match the Prod or Call cases again). plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1 -- Otherwise (Call `lub` Prod) return Top -plusSubDmd _ _ = topSubDmd +plusSubDmd _ _ = topSubDmd -- | Denotes '+' on 'Demand'. plusDmd :: Demand -> Demand -> Demand plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2 --- | The trivial cases of the @mult*@ functions. --- If @multTrivial n abs a = ma@, we have the following outcomes --- depending on @n@: --- --- * 'C_11' => multiply by one, @ma = Just a@ --- * 'C_00', 'C_10' (e.g. @'isAbs' n@) => return the absent thing, --- @ma = Just abs@ --- * Otherwise ('C_01', 'C_*N') it's not a trivial case, @ma = Nothing@. -multTrivial :: Card -> a -> a -> Maybe a -multTrivial C_11 _ a = Just a -multTrivial n abs _ | isAbs n = Just abs -multTrivial _ _ _ = Nothing - multSubDmd :: Card -> SubDemand -> SubDemand -multSubDmd n sd - | Just sd' <- multTrivial n seqSubDmd sd = sd' -multSubDmd n (Poly n') = Poly (multCard n n') -multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative] -multSubDmd n (Prod ds) = Prod (map (multDmd n) ds) +multSubDmd C_11 sd = sd +multSubDmd C_00 _ = seqSubDmd +multSubDmd C_10 (Poly n) = if isStrict n then botSubDmd else seqSubDmd +multSubDmd C_10 (Call n _) = if isStrict n then botSubDmd else seqSubDmd +multSubDmd n (Poly m) = Poly (multCard n m) +multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative] +multSubDmd n (Prod ds) = Prod (strictMap (multDmd n) ds) multDmd :: Card -> Demand -> Demand -multDmd n dmd - | Just dmd' <- multTrivial n absDmd dmd = dmd' -multDmd n (m :* dmd) = multCard n m :* multSubDmd n dmd +-- The first two lines compute the same result as the last line, but won't +-- trigger the assertion in `:*` for input like `multDmd B 1L`, which would call +-- `B :* A`. We want to return `B` in these cases. +multDmd C_10 (n :* _) = if isStrict n then BotDmd else AbsDmd +multDmd n (C_10 :* _) = if isStrict n then BotDmd else AbsDmd +multDmd n (m :* sd) = multCard n m :* multSubDmd n sd -- | Used to suppress pretty-printing of an uninformative demand isTopDmd :: Demand -> Bool @@ -466,7 +580,7 @@ isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) isSeqDmd :: Demand -> Bool isSeqDmd (C_11 :* sd) = sd == seqSubDmd -isSeqDmd (C_1N :* sd) = sd == seqSubDmd -- I wonder if we need this case. +isSeqDmd (C_1N :* sd) = sd == seqSubDmd isSeqDmd _ = False -- | Is the value used at most once? @@ -481,11 +595,14 @@ isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd where -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@, -- e.g. if @thing@ is idempotent wrt. to @plus@. - is_plus_idem_card c = plusCard c c == c + -- is_plus_idem_card n = plusCard n n == n + is_plus_idem_card = isCardNonOnce -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd + is_plus_idem_dmd AbsDmd = True + is_plus_idem_dmd BotDmd = True is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd - is_plus_idem_sub_dmd (Poly n) = is_plus_idem_card n + is_plus_idem_sub_dmd (Poly n) = assert (isCardNonOnce n) True is_plus_idem_sub_dmd (Prod ds) = all is_plus_idem_dmd ds is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative] @@ -514,10 +631,14 @@ lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd) -- | Make a 'Demand' evaluated at-most-once. oneifyDmd :: Demand -> Demand +oneifyDmd AbsDmd = AbsDmd +oneifyDmd BotDmd = BotDmd oneifyDmd (n :* sd) = oneifyCard n :* sd -- | Make a 'Demand' evaluated at-least-once (e.g. strict). strictifyDmd :: Demand -> Demand +strictifyDmd AbsDmd = BotDmd +strictifyDmd BotDmd = BotDmd strictifyDmd (n :* sd) = plusCard C_10 n :* sd -- | If the argument is a used non-newtype dictionary, give it strict demand. @@ -557,6 +678,13 @@ mkCalledOnceDmd sd = mkCall C_11 sd mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity +-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'TopSubDmd' and +-- 'SeqSubDmd' as necessary. +viewCall :: SubDemand -> Maybe (Card, SubDemand) +viewCall (Call n sd) = Just (n :: Card, sd) +viewCall (Poly n) = Just (n :: Card, Poly n) +viewCall _ = Nothing + -- | Peels one call level from the sub-demand, and also returns how many -- times we entered the lambda body. peelCallDmd :: SubDemand -> (Card, SubDemand) @@ -578,15 +706,14 @@ mkWorkerDemand n = C_01 :* go n where go 0 = topSubDmd go n = Call C_01 $ go (n-1) +-- | Precondition: The SubDemand is not a Call addCaseBndrDmd :: SubDemand -- On the case binder -> [Demand] -- On the components of the constructor -> [Demand] -- Final demands for the components of the constructor -addCaseBndrDmd (Poly n) alt_dmds - | isAbs n = alt_dmds --- See Note [Demand on case-alternative binders] -addCaseBndrDmd sd alt_dmds = zipWith plusDmd ds alt_dmds -- fuse ds! - where - Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call +addCaseBndrDmd sd alt_dmds + -- See Note [Demand on case-alternative binders] + | Prod ds <- plusSubDmd sd (Prod alt_dmds) = ds + | otherwise = alt_dmds argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] @@ -606,6 +733,9 @@ argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args argOneShots :: Demand -- ^ depending on saturation -> [OneShotInfo] -- ^ See Note [Computing one-shot info] +argOneShots AbsDmd = [] -- This defn conflicts with 'saturatedByOneShots', +argOneShots BotDmd = [] -- according to which we should return + -- @repeat OneShotLam@ here... argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative] where go (Call n sd) @@ -619,6 +749,8 @@ argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative] -- There are at least n nested CM(..) calls. -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots _ AbsDmd = True +saturatedByOneShots _ BotDmd = True saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd) {- Note [Strict demands] @@ -678,8 +810,8 @@ is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures that @g@ above actually gets the @1P(L)@ demand on its second pair component, rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand. -Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand on a binder in a case alternative comes (a) From the demand on the binder itself (b) From the demand on the case binder @@ -1086,9 +1218,9 @@ emptyDmdEnv :: DmdEnv emptyDmdEnv = emptyVarEnv multDmdEnv :: Card -> DmdEnv -> DmdEnv -multDmdEnv n env - | Just env' <- multTrivial n emptyDmdEnv env = env' - | otherwise = mapVarEnv (multDmd n) env +multDmdEnv C_11 env = env +multDmdEnv C_00 _ = emptyDmdEnv +multDmdEnv n env = mapVarEnv (multDmd n) env reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N @@ -1539,9 +1671,9 @@ dmdTransformDataConSig arity sd = case go arity sd of Just dmds -> DmdType emptyDmdEnv dmds topDiv Nothing -> nopDmdType -- Not saturated where - go 0 sd = viewProd arity sd - go n (viewCall -> Just (C_11, sd)) = go (n-1) sd -- strict calls only! - go _ _ = Nothing + go 0 sd = viewProd arity sd + go n (Call C_11 sd) = go (n-1) sd -- strict calls only! + go _ _ = Nothing -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). @@ -1680,12 +1812,14 @@ kill_usage_card kfs C_11 | kf_used_once kfs = C_1N kill_usage_card _ n = n kill_usage :: KillFlags -> Demand -> Demand +kill_usage _ AbsDmd = AbsDmd +kill_usage _ BotDmd = BotDmd kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd kill_usage_sd :: KillFlags -> SubDemand -> SubDemand kill_usage_sd kfs (Call n sd) | kf_called_once kfs = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd) - | otherwise = mkCall n (kill_usage_sd kfs sd) + | otherwise = mkCall n (kill_usage_sd kfs sd) kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds) kill_usage_sd _ sd = sd @@ -1704,6 +1838,8 @@ data TypeShape -- See Note [Trimming a demand to a type] trimToType :: Demand -> TypeShape -> Demand -- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal +trimToType AbsDmd _ = AbsDmd +trimToType BotDmd _ = BotDmd trimToType (n :* sd) ts = n :* go sd ts where @@ -1722,6 +1858,8 @@ trimToType (n :* sd) ts -} seqDemand :: Demand -> () +seqDemand AbsDmd = () +seqDemand BotDmd = () seqDemand (_ :* sd) = seqSubDemand sd seqSubDemand :: SubDemand -> () @@ -1750,6 +1888,15 @@ seqDmdSig (DmdSig ty) = seqDmdType ty ************************************************************************ -} +-- Just for debugging purposes. +instance Show Card where + show C_00 = "C_00" + show C_01 = "C_01" + show C_0N = "C_0N" + show C_10 = "C_10" + show C_11 = "C_11" + show C_1N = "C_1N" + {- Note [Demand notation] ~~~~~~~~~~~~~~~~~~~~~~~~~ This Note should be kept up to date with the documentation of `-fstrictness` @@ -1810,10 +1957,11 @@ instance Outputable Card where -- | See Note [Demand notation] instance Outputable Demand where - ppr dmd@(n :* sd) - | isAbs n = ppr n -- If absent, sd is arbitrary - | dmd == polyDmd n = ppr n -- Print UU as just U - | otherwise = ppr n <> ppr sd + ppr AbsDmd = char 'A' + ppr BotDmd = char 'B' + ppr (C_0N :* Poly C_0N) = char 'L' -- Print LL as just L + ppr (C_1N :* Poly C_1N) = char 'S' -- Dito SS + ppr (n :* sd) = ppr n <> ppr sd -- | See Note [Demand notation] instance Outputable SubDemand where @@ -1868,8 +2016,14 @@ instance Binary Card where _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int)) instance Binary Demand where - put_ bh (n :* sd) = put_ bh n *> put_ bh sd - get bh = (:*) <$> get bh <*> get bh + put_ bh (n :* sd) = put_ bh n *> case n of + C_00 -> return () + C_10 -> return () + _ -> put_ bh sd + get bh = get bh >>= \n -> case n of + C_00 -> return AbsDmd + C_10 -> return BotDmd + _ -> (n :*) <$> get bh instance Binary SubDemand where put_ bh (Poly sd) = putByte bh 0 *> put_ bh sd |