never executed always true always false
    1 {-# LANGUAGE ViewPatterns #-}
    2 {-# LANGUAGE BinaryLiterals #-}
    3 {-# LANGUAGE PatternSynonyms #-}
    4 
    5 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    6 
    7 {-
    8 (c) The University of Glasgow 2006
    9 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   10 -}
   11 
   12 -- | A language to express the evaluation context of an expression as a
   13 -- 'Demand' and track how an expression evaluates free variables and arguments
   14 -- in turn as a 'DmdType'.
   15 --
   16 -- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal".
   17 module GHC.Types.Demand (
   18     -- * Demands
   19     Boxity(..),
   20     Card(C_00, C_01, C_0N, C_10, C_11, C_1N), CardNonAbs, CardNonOnce,
   21     Demand(AbsDmd, BotDmd, (:*)),
   22     SubDemand(Prod, Poly), mkProd, viewProd, unboxSubDemand,
   23     -- ** Algebra
   24     absDmd, topDmd, botDmd, seqDmd, topSubDmd,
   25     -- *** Least upper bound
   26     lubCard, lubDmd, lubSubDmd,
   27     -- *** Plus
   28     plusCard, plusDmd, plusSubDmd,
   29     -- *** Multiply
   30     multCard, multDmd, multSubDmd,
   31     -- ** Predicates on @Card@inalities and @Demand@s
   32     isAbs, isUsedOnce, isStrict,
   33     isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,
   34     isTopDmd, isWeakDmd,
   35     -- ** Special demands
   36     evalDmd,
   37     -- *** Demands used in PrimOp signatures
   38     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
   39     -- ** Other @Demand@ operations
   40     oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,
   41     peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,
   42     -- ** Extracting one-shot information
   43     argOneShots, argsOneShots, saturatedByOneShots,
   44 
   45     -- * Demand environments
   46     DmdEnv, emptyDmdEnv,
   47     keepAliveDmdEnv, reuseEnv,
   48 
   49     -- * Divergence
   50     Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,
   51 
   52     -- * Demand types
   53     DmdType(..), dmdTypeDepth,
   54     -- ** Algebra
   55     nopDmdType, botDmdType,
   56     lubDmdType, plusDmdType, multDmdType,
   57     -- *** PlusDmdArg
   58     PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,
   59     -- ** Other operations
   60     peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
   61     keepAliveDmdType,
   62 
   63     -- * Demand signatures
   64     DmdSig(..), mkDmdSigForArity, mkClosedDmdSig,
   65     splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,
   66     nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd,
   67     -- ** Handling arity adjustments
   68     prependArgsDmdSig, etaConvertDmdSig,
   69 
   70     -- * Demand transformers from demand signatures
   71     DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
   72 
   73     -- * Trim to a type shape
   74     TypeShape(..), trimToType, trimBoxity,
   75 
   76     -- * @seq@ing stuff
   77     seqDemand, seqDemandList, seqDmdType, seqDmdSig,
   78 
   79     -- * Zapping usage information
   80     zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig
   81   ) where
   82 
   83 import GHC.Prelude
   84 
   85 import GHC.Types.Var ( Var, Id )
   86 import GHC.Types.Var.Env
   87 import GHC.Types.Var.Set
   88 import GHC.Types.Unique.FM
   89 import GHC.Types.Basic
   90 import GHC.Data.Maybe   ( orElse )
   91 
   92 import GHC.Core.Type    ( Type )
   93 import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )
   94 import GHC.Core.DataCon ( splitDataProductType_maybe )
   95 import GHC.Core.Multiplicity    ( scaledThing )
   96 
   97 import GHC.Utils.Binary
   98 import GHC.Utils.Misc
   99 import GHC.Utils.Outputable
  100 import GHC.Utils.Panic
  101 import GHC.Utils.Panic.Plain
  102 
  103 import Data.Function
  104 
  105 import GHC.Utils.Trace
  106 _ = pprTrace -- Tired of commenting out the import all the time
  107 
  108 {-
  109 ************************************************************************
  110 *                                                                      *
  111            Boxity: Whether the box of something is used
  112 *                                                                      *
  113 ************************************************************************
  114 -}
  115 
  116 {- Note [Strictness and Unboxing]
  117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  118 If an argument is used strictly by the function body, we may use use
  119 call-by-value instead of call-by-need for that argument. What's more, we may
  120 unbox an argument that is used strictly, discarding the box at the call site.
  121 This can reduce allocations of the program drastically if the box really isn't
  122 needed in the function body. Here's an example:
  123 ```
  124 even :: Int -> Bool
  125 even (I# 0) = True
  126 even (I# 1) = False
  127 even (I# n) = even (I# (n -# 2))
  128 ```
  129 All three code paths of 'even' are (a) strict in the argument, and (b)
  130 immediately discard the boxed 'Int'. Now if we have a call site like
  131 `even (I# 42)`, then it would be terrible to allocate the 'I#' box for the
  132 argument only to tear it apart immediately in the body of 'even'! Hence,
  133 worker/wrapper will allocate a wrapper for 'even' that not only uses
  134 call-by-value for the argument (e.g., `case I# 42 of b { $weven b }`), but also
  135 *unboxes* the argument, resulting in
  136 ```
  137 even :: Int -> Bool
  138 even (I# n) = $weven n
  139 $weven :: Int# -> Bool
  140 $weven 0 = True
  141 $weven 1 = False
  142 $weven n = $weven (n -# 2)
  143 ```
  144 And now the box in `even (I# 42)` will cancel away after inlining the wrapper.
  145 
  146 As far as the permission to unbox is concerned, *evaluatedness* of the argument
  147 is the important trait. Unboxing implies eager evaluation of an argument and
  148 we don't want to change the termination properties of the function. One way
  149 to ensure that is to unbox strict arguments only, but strictness is only a
  150 sufficient condition for evaluatedness.
  151 See Note [Unboxing evaluated arguments] in "GHC.Core.Opt.WorkWrap.Utils", where
  152 we manage to unbox *strict fields* of unboxed arguments that the function is not
  153 actually strict in, simply by realising that those fields have to be evaluated.
  154 
  155 Note [Boxity analysis]
  156 ~~~~~~~~~~~~~~~~~~~~~~
  157 Alas, we don't want to unbox *every* strict argument
  158 (as Note [Strictness and Unboxing] might suggest).
  159 Here's an example (from T19871):
  160 ```
  161 data Huge = H Bool Bool ... Bool
  162 ann :: Huge -> (Bool, Huge)
  163 ann h@(Huge True _ ... _) = (False, h)
  164 ann h                     = (True,  h)
  165 ```
  166 Unboxing 'h' yields
  167 ```
  168 $wann :: Bool -> Bool -> ... -> Bool -> (Bool, Huge)
  169 $wann True b2 ... bn = (False, Huge True b2 ... bn)
  170 $wann b1   b2 ... bn = (True,  Huge b1   b2 ... bn)
  171 ```
  172 The pair constructor really needs its fields boxed. But '$wann' doesn't get
  173 passed 'h' anymore, only its components! Ergo it has to reallocate the 'Huge'
  174 box, in a process called "reboxing". After w/w, call sites like
  175 `case ... of Just h -> ann h` pay for the allocation of the additional box.
  176 In earlier versions of GHC we simply accepted that reboxing would sometimes
  177 happen, but we found some cases where it made a big difference: #19407, for
  178 example.
  179 
  180 We therefore perform a simple syntactic boxity analysis that piggy-backs on
  181 demand analysis in order to determine whether the box of a strict argument is
  182 always discarded in the function body, in which case we can pass it unboxed
  183 without risking regressions such as in 'ann' above. But as soon as one use needs
  184 the box, we want Boxed to win over any Unboxed uses.
  185 (We don't adhere to that in 'lubBoxity', see Note [lubBoxity and plusBoxity].)
  186 
  187 The demand signature (cf. Note [Demand notation]) will say whether it uses
  188 its arguments boxed or unboxed. Indeed it does so for every sub-component of
  189 the argument demand. Here's an example:
  190 ```
  191 f :: (Int, Int) -> Bool
  192 f (a, b) = even (a + b) -- demand signature: <1!P(1!L,1!L)>
  193 ```
  194 The '!' indicates places where we want to unbox, the lack thereof indicates the
  195 box is used by the function. Boxity flags are part of the 'Poly' and 'Prod'
  196 'SubDemand's, see Note [Why Boxity in SubDemand and not in Demand?].
  197 The given demand signature says "Unbox the pair and then nestedly unbox its
  198 two fields". By contrast, the demand signature of 'ann' above would look like
  199 <1P(1L,L,...,L)>, lacking any '!'.
  200 
  201 A demand signature like <1P(1!L)> -- Boxed outside but Unboxed in the field --
  202 doesn't make a lot of sense, as we can never unbox the field without unboxing
  203 the containing record. See Note [Finalising boxity for demand signature] in
  204 "GHC.Core.Opt.WorkWrap.Utils" for how we avoid to spread this and other kinds of
  205 misinformed boxities.
  206 
  207 Due to various practical reasons, Boxity Analysis is not conservative at times.
  208 Here are reasons for too much optimism:
  209 
  210  * Note [Function body boxity and call sites] is an observation about when it is
  211    beneficial to unbox a parameter that is returned from a function.
  212    Note [Unboxed demand on function bodies returning small products] derives
  213    a heuristic from the former Note, pretending that all call sites of a
  214    function need returned small products Unboxed.
  215  * Note [lubBoxity and plusBoxity] describes why we optimistically let Unboxed
  216    win when combining different case alternatives.
  217 
  218 Boxity analysis fixes a number of issues:
  219 #19871, #19407, #4267, #16859, #18907, #13331
  220 
  221 Note [Function body boxity and call sites]
  222 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  223 Consider (from T5949)
  224 ```
  225 f n p = case n of
  226   0 -> p :: (a, b)
  227   _ -> f (n-1) p
  228 -- Worker/wrapper split if we decide to unbox:
  229 $wf n x y = case n of
  230   0 -> (# x, y #)
  231   _ -> $wf (n-1) x y
  232 f n (x,y) = case $wf n x y of (# r, s #) -> (r,s)
  233 ```
  234 When is it better to /not/ to unbox 'p'? That depends on the callers of 'f'!
  235 If all call sites
  236 
  237  1. Wouldn't need to allocate fresh boxes for 'p', and
  238  2. Needed the result pair of 'f' boxed
  239 
  240 Only then we'd see an increase in allocation resulting from unboxing. But as
  241 soon as only one of (1) or (2) holds, it really doesn't matter if 'f' unboxes
  242 'p' (and its result, it's important that CPR follows suit). For example
  243 ```
  244 res = ... case f m (field t) of (r1,r2) -> ...  -- (1) holds
  245 arg = ... [ f m (x,y) ] ...                     -- (2) holds
  246 ```
  247 Because one of the boxes in the call site can cancel away:
  248 ```
  249 res = ... case field1 t of (x1,x2) ->
  250           case field2 t of (y1,y2) ->
  251           case $wf x1 x2 y1 y2 of (#r1,r2#) -> ...
  252 arg = ... [ case $wf x1 x2 y1 y2 of (#r1,r2#) -> (r1,r2) ] ...
  253 ```
  254 And when call sites neither have arg boxes (1) nor need the result boxed (2),
  255 then hesitating to unbox means /more/ allocation in the call site because of the
  256 need for fresh argument boxes.
  257 
  258 Summary: If call sites that satisfy both (1) and (2) occur more often than call
  259 sites that satisfy neither condition, then it's best /not/ to unbox 'p'.
  260 
  261 Note [Unboxed demand on function bodies returning small products]
  262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  263 Note [Boxity analysis] achieves its biggest wins when we avoid reboxing huge
  264 records. But when we return small products from a function, we often get faster
  265 programs by pretending that the caller unboxes the result. Long version:
  266 
  267 Observation: Big record arguments (e.g., DynFlags) tend to be modified much less
  268              frequently than small records (e.g., Int).
  269 Result:      Big records tend to be passed around boxed (unmodified) much more
  270              frequently than small records.
  271 Consequnce:  The larger the record, the more likely conditions (1) and (2) from
  272              Note [Function body boxity and call sites] are met, in which case
  273              unboxing returned parameters leads to reboxing.
  274 
  275 So we put an Unboxed demand on function bodies returning small products and a
  276 Boxed demand on the others. What is regarded a small product is controlled by
  277 the -fdmd-unbox-width flag.
  278 
  279 This also manages to unbox functions like
  280 ```
  281 sum z      []          = z
  282 sum (I# n) ((I# x):xs) = sum (I# (n +# x)) xs
  283 ```
  284 where we can unbox 'z' on the grounds that it's but a small box anyway. That in
  285 turn means that the I# allocation in the recursive call site can cancel away and
  286 we get a non-allocating loop, nice and tight.
  287 Note that this is the typical case in "Observation" above: A small box is
  288 unboxed, modified, the result reboxed for the recursive call.
  289 
  290 Originally, this came up in binary-trees' check' function and #4267 which
  291 (similarly) features a strict fold over a tree. We'd also regress in join004 and
  292 join007 if we didn't assume an optimistic Unboxed demand on the function body.
  293 T17932 features a (non-recursive) function that returns a large record, e.g.,
  294 ```
  295 flags (Options f x) = <huge> `seq` f
  296 ```
  297 and here we won't unbox 'f' because it has 5 fields (which is larger than the
  298 default -fdmd-unbox-width threshold).
  299 
  300 Why not focus on putting Unboxed demands on all recursive function?
  301 Then we'd unbox
  302 ```
  303 flags 0 (Options f x) = <huge> `seq` f
  304 flags n o             = flags (n-1) o
  305 ```
  306 and that seems hardly useful.
  307 (NB: Similar to 'f' from Note [Preserving Boxity of results is rarely a win],
  308 but there we only had 2 fields.)
  309 
  310 Note [lubBoxity and plusBoxity]
  311 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  312 Should 'Boxed' win in 'lubBoxity' and 'plusBoxity'?
  313 The first intuition is Yes, because that would be the conservative choice:
  314 Responding 'Boxed' when there's the slightest chance we might need the box means
  315 we'll never need to rebox a value.
  316 
  317 For 'plusBoxity' the choice of 'boxedWins' is clear: When we need a value to be
  318 Boxed and Unboxed /in the same trace/, then we clearly need it to be Boxed.
  319 
  320 But if we chose 'boxedWins' for 'lubBoxity', we'd regress T3586. Smaller example
  321 ```
  322 sumIO :: Int -> Int -> IO Int
  323 sumIO 0 !z = return z
  324 sumIO n !z = sumIO (n-1) (z+n)
  325 ```
  326 We really want 'z' to unbox here. Yet its use in the returned unboxed pair
  327 is fundamentally a Boxed one! CPR would manage to unbox it, but DmdAnal runs
  328 before that. There is an Unboxed use in the recursive call to 'go' though.
  329 So we choose 'unboxedWins' for 'lubBoxity' to collect this win.
  330 
  331 Choosing 'unboxedWins' is not conservative. There clearly is ample room for
  332 examples that get worse by our choice. Here's a simple one (from T19871):
  333 ```
  334 data Huge = H { f1 :: Bool, ... many fields ... }
  335 update :: Huge -> (Bool, Huge)
  336 update h@(Huge{f1=True}) = (False, h{f1=False})
  337 update h                 = (True,  h)
  338 ```
  339 Here, we decide to unbox 'h' because it's used Unboxed in the first branch.
  340 
  341 Note that this is fundamentally working around a phase problem, namely that the
  342 results of boxity analysis depend on CPR analysis (and vice versa, of course).
  343 -}
  344 
  345 boxedWins :: Boxity -> Boxity -> Boxity
  346 boxedWins Unboxed Unboxed = Unboxed
  347 boxedWins _       !_      = Boxed
  348 
  349 unboxedWins :: Boxity -> Boxity -> Boxity
  350 unboxedWins Boxed Boxed = Boxed
  351 unboxedWins _     !_    = Unboxed
  352 
  353 lubBoxity :: Boxity -> Boxity -> Boxity
  354 -- See Note [Boxity analysis] for the lattice.
  355 -- See Note [lubBoxity and plusBoxity].
  356 lubBoxity = unboxedWins
  357 
  358 plusBoxity :: Boxity -> Boxity -> Boxity
  359 -- See Note [lubBoxity and plusBoxity].
  360 plusBoxity = boxedWins
  361 
  362 {-
  363 ************************************************************************
  364 *                                                                      *
  365            Card: Combining Strictness and Usage
  366 *                                                                      *
  367 ************************************************************************
  368 -}
  369 
  370 {- Note [Evaluation cardinalities]
  371 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  372 The demand analyser uses an (abstraction of) /evaluation cardinality/ of type
  373 Card, to specify how many times a term is evaluated. A Card C_lu
  374 represents an /interval/ of possible cardinalities [l..u], meaning
  375 
  376 * Evaluated /at least/ 'l' times (strictness).
  377   Hence 'l' is either 0 (lazy)
  378                    or 1 (strict)
  379 
  380 * Evaluated /at most/ 'u' times (usage).
  381   Hence 'u' is either 0 (not used at all),
  382                    or 1 (used at most once)
  383                    or n (no information)
  384 
  385 Intervals describe sets, so the underlying lattice is the powerset lattice.
  386 
  387 Usually l<=u, but we also have C_10, the interval [1,0], the empty interval,
  388 denoting the empty set.   This is the bottom element of the lattice.
  389 
  390 See Note [Demand notation] for the notation we use for each of the constructors.
  391 
  392 Note [Bit vector representation for Card]
  393 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  394 While the 6 inhabitants of Card admit an efficient representation as an
  395 enumeration, implementing operations such as lubCard, plusCard and multCard
  396 leads to unreasonably bloated code. This was the old defn for lubCard, for
  397 example:
  398 
  399   -- Handle C_10 (bot)
  400   lubCard C_10 n    = n    -- bot
  401   lubCard n    C_10 = n    -- bot
  402   -- Handle C_0N (top)
  403   lubCard C_0N _    = C_0N -- top
  404   lubCard _    C_0N = C_0N -- top
  405   -- Handle C_11
  406   lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1}
  407   lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1}
  408   lubCard C_11 n    = n    -- {1} is a subset of all other intervals
  409   lubCard n    C_11 = n    -- {1} is a subset of all other intervals
  410   -- Handle C_1N
  411   lubCard C_1N C_1N = C_1N -- reflexivity
  412   lubCard _    C_1N = C_0N -- {0} ∪ {1,n} = top
  413   lubCard C_1N _    = C_0N -- {0} ∪ {1,n} = top
  414   -- Handle C_01
  415   lubCard C_01 _    = C_01 -- {0} ∪ {0,1} = {0,1}
  416   lubCard _    C_01 = C_01 -- {0} ∪ {0,1} = {0,1}
  417   -- Handle C_00
  418   lubCard C_00 C_00 = C_00 -- reflexivity
  419 
  420 There's a much more compact way to encode these operations if Card is
  421 represented not as distinctly denoted intervals, but as the subset of the set
  422 of all cardinalities {0,1,n} instead. We represent such a subset as a bit vector
  423 of length 3 (which fits in an Int). That's actually pretty common for such
  424 powerset lattices.
  425 There's one bit per denoted cardinality that is set iff that cardinality is part
  426 of the denoted set, with n being the most significand bit (index 2) and 0 being
  427 represented by the least significand bit (index 0).
  428 
  429 How does that help? Well, for one, lubCard just becomes
  430 
  431   lubCard (Card a) (Card b) = Card (a .|. b)
  432 
  433 The other operations, 'plusCard' and 'multCard', become significantly more
  434 tricky, but immensely more compact. It's all straight-line code with a few bit
  435 twiddling instructions now!
  436 
  437 Note [Algebraic specification for plusCard and multCard]
  438 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  439 The representation change in Note [Bit vector representation for Card] admits
  440 very dense definitions of 'plusCard' and 'multCard' in terms of bit twiddling,
  441 but the connection to the algebraic operations they implement is lost.
  442 It's helpful to have a written specification of what 'plusCard' and 'multCard'
  443 here that says what they should compute.
  444 
  445   * plusCard: a@[l1,u1] + b@[l2,u2] = r@[l1+l2,u1+u2].
  446       - In terms of sets, 0 ∈ r iff 0 ∈ a and 0 ∈ b.
  447         Examples: set in C_00 + C_00, C_01 + C_0N, but not in C_10 + C_00
  448       - In terms of sets, 1 ∈ r iff 1 ∈ a or 1 ∈ b.
  449         Examples: set in C_01 + C_00, C_0N + C_0N, but not in C_10 + C_00
  450       - In terms of sets, n ∈ r iff n ∈ a or n ∈ b, or (1 ∈ a and 1 ∈ b),
  451         so not unlike add with carry.
  452         Examples: set in C_01 + C_01, C_01 + C_0N, but not in C_10 + C_01
  453       - Handy special cases:
  454           o 'plusCard C_10' bumps up the strictness of its argument, just like
  455             'lubCard C_00' lazifies it, without touching upper bounds.
  456           o Similarly, 'plusCard C_0N' discards usage information
  457             (incl. absence) but leaves strictness alone.
  458 
  459   * multCard: a@[l1,u1] * b@[l2,u2] = r@[l1*l2,u1*u2].
  460       - In terms of sets, 0 ∈ r iff 0 ∈ a or 0 ∈ b.
  461         Examples: set in C_00 * C_10, C_01 * C_1N, but not in C_10 * C_1N
  462       - In terms of sets, 1 ∈ r iff 1 ∈ a and 1 ∈ b.
  463         Examples: set in C_01 * C_01, C_01 * C_1N, but not in C_11 * C_10
  464       - In terms of sets, n ∈ r iff 1 ∈ r and (n ∈ a or n ∈ b).
  465         Examples: set in C_1N * C_01, C_1N * C_0N, but not in C_10 * C_1N
  466       - Handy special cases:
  467           o 'multCard C_1N c' is the same as 'plusCard c c' and
  468             drops used-once info. But unlike 'plusCard C_0N', it leaves absence
  469             and strictness.
  470           o 'multCard C_01' drops strictness info, like 'lubCard C_00'.
  471           o 'multCard C_0N' does both; it discards all strictness and used-once
  472             info and retains only absence info.
  473 -}
  474 
  475 
  476 -- | Describes an interval of /evaluation cardinalities/.
  477 -- See Note [Evaluation cardinalities]
  478 -- See Note [Bit vector representation for Card]
  479 newtype Card = Card Int
  480   deriving Eq
  481 
  482 -- | A subtype of 'Card' for which the upper bound is never 0 (no 'C_00' or
  483 -- 'C_10'). The only four inhabitants are 'C_01', 'C_0N', 'C_11', 'C_1N'.
  484 -- Membership can be tested with 'isCardNonAbs'.
  485 -- See 'D' and 'Call' for use sites and explanation.
  486 type CardNonAbs = Card
  487 
  488 -- | A subtype of 'Card' for which the upper bound is never 1 (no 'C_01' or
  489 -- 'C_11'). The only four inhabitants are 'C_00', 'C_0N', 'C_10', 'C_1N'.
  490 -- Membership can be tested with 'isCardNonOnce'.
  491 -- See 'Poly' for use sites and explanation.
  492 type CardNonOnce = Card
  493 
  494 -- | Absent, {0}. Pretty-printed as A.
  495 pattern C_00 :: Card
  496 pattern C_00 = Card 0b001
  497 -- | Bottom, {}. Pretty-printed as A.
  498 pattern C_10 :: Card
  499 pattern C_10 = Card 0b000
  500 -- | Strict and used once, {1}. Pretty-printed as 1.
  501 pattern C_11 :: Card
  502 pattern C_11 = Card 0b010
  503 -- | Used at most once, {0,1}. Pretty-printed as M.
  504 pattern C_01 :: Card
  505 pattern C_01 = Card 0b011
  506 -- | Strict and used (possibly) many times, {1,n}. Pretty-printed as S.
  507 pattern C_1N :: Card
  508 pattern C_1N = Card 0b110
  509 -- | Every possible cardinality; the top element, {0,1,n}. Pretty-printed as L.
  510 pattern C_0N :: Card
  511 pattern C_0N = Card 0b111
  512 
  513 {-# COMPLETE C_00, C_01, C_0N, C_10, C_11, C_1N :: Card #-}
  514 
  515 _botCard, topCard :: Card
  516 _botCard = C_10
  517 topCard = C_0N
  518 
  519 -- | True <=> lower bound is 1.
  520 isStrict :: Card -> Bool
  521 -- See Note [Bit vector representation for Card]
  522 isStrict (Card c) = c .&. 0b001 == 0 -- simply check 0 bit is not set
  523 
  524 -- | True <=> upper bound is 0.
  525 isAbs :: Card -> Bool
  526 -- See Note [Bit vector representation for Card]
  527 isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set
  528 
  529 -- | True <=> upper bound is 1.
  530 isUsedOnce :: Card -> Bool
  531 -- See Note [Bit vector representation for Card]
  532 isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set
  533 
  534 -- | Is this a 'CardNonAbs'?
  535 isCardNonAbs :: Card -> Bool
  536 isCardNonAbs = not . isAbs
  537 
  538 -- | Is this a 'CardNonOnce'?
  539 isCardNonOnce :: Card -> Bool
  540 isCardNonOnce n = isAbs n || not (isUsedOnce n)
  541 
  542 -- | Intersect with [0,1].
  543 oneifyCard :: Card -> Card
  544 oneifyCard C_0N = C_01
  545 oneifyCard C_1N = C_11
  546 oneifyCard c    = c
  547 
  548 -- | Denotes '∪' on 'Card'.
  549 lubCard :: Card -> Card -> Card
  550 -- See Note [Bit vector representation for Card]
  551 lubCard (Card a) (Card b) = Card (a .|. b) -- main point of the bit-vector encoding!
  552 
  553 -- | Denotes '+' on lower and upper bounds of 'Card'.
  554 plusCard :: Card -> Card -> Card
  555 -- See Note [Algebraic specification for plusCard and multCard]
  556 plusCard (Card a) (Card b)
  557   = Card (bit0 .|. bit1 .|. bitN)
  558   where
  559     bit0 =  (a .&. b)                         .&. 0b001
  560     bit1 =  (a .|. b)                         .&. 0b010
  561     bitN = ((a .|. b) .|. shiftL (a .&. b) 1) .&. 0b100
  562 
  563 -- | Denotes '*' on lower and upper bounds of 'Card'.
  564 multCard :: Card -> Card -> Card
  565 -- See Note [Algebraic specification for plusCard and multCard]
  566 multCard (Card a) (Card b)
  567   = Card (bit0 .|. bit1 .|. bitN)
  568   where
  569     bit0 = (a .|. b)                   .&. 0b001
  570     bit1 = (a .&. b)                   .&. 0b010
  571     bitN = (a .|. b) .&. shiftL bit1 1 .&. 0b100
  572 
  573 {-
  574 ************************************************************************
  575 *                                                                      *
  576            Demand: Evaluation contexts
  577 *                                                                      *
  578 ************************************************************************
  579 -}
  580 
  581 -- | A demand describes a /scaled evaluation context/, e.g. how many times
  582 -- and how deep the denoted thing is evaluated.
  583 --
  584 -- The "how many" component is represented by a 'Card'inality.
  585 -- The "how deep" component is represented by a 'SubDemand'.
  586 -- Examples (using Note [Demand notation]):
  587 --
  588 --   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument
  589 --     strictly (@1@), but not any deeper (@A@).
  590 --   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument
  591 --     pair strictly and the first component strictly, but no nested info
  592 --     beyond that (@L@). Its second argument is not used at all.
  593 --   * '$' puts demand @1C1(L)@ on its first argument: It calls (@C@) the
  594 --     argument function with one argument, exactly once (@1@). No info
  595 --     on how the result of that call is evaluated (@L@).
  596 --   * 'maybe' puts demand @MCM(L)@ on its second argument: It evaluates
  597 --     the argument function at most once ((M)aybe) and calls it once when
  598 --     it is evaluated.
  599 --   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@
  600 --     multiplied by two, so we get @S@ (used at least once, possibly multiple
  601 --     times).
  602 --
  603 -- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled
  604 -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of
  605 -- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and
  606 -- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there
  607 -- isn't any evaluation at all. If you don't care, simply use '(:*)'.
  608 data Demand
  609   = BotDmd
  610   -- ^ A bottoming demand, produced by a diverging function, hence there is no
  611   -- 'SubDemand' that describes how it was evaluated.
  612   | AbsDmd
  613   -- ^ An absent demand: Evaluated exactly 0 times ('C_00'), hence there is no
  614   -- 'SubDemand' that describes how it was evaluated.
  615   | D !CardNonAbs !SubDemand
  616   -- ^ Don't use this internal data constructor; use '(:*)' instead.
  617   deriving Eq
  618 
  619 -- | Only meant to be used in the pattern synonym below!
  620 viewDmdPair :: Demand -> (Card, SubDemand)
  621 viewDmdPair BotDmd   = (C_10, botSubDmd)
  622 viewDmdPair AbsDmd   = (C_00, seqSubDmd)
  623 viewDmdPair (D n sd) = (n, sd)
  624 
  625 -- | @c :* sd@ is a demand that says \"evaluated @c@ times, and each time it
  626 -- was evaluated, it was at least as deep as @sd@\".
  627 --
  628 -- Matching on this pattern synonym is a complete match.
  629 -- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@.
  630 -- If the matched demand was 'BotDmd', it will match as @C_10 :* botSubDmd@.
  631 -- The builder of this pattern synonym simply /discards/ the 'SubDemand' if the
  632 -- 'Card' was absent and returns 'AbsDmd' or 'BotDmd' instead. It will assert
  633 -- that the discarded sub-demand was 'seqSubDmd' and 'botSubDmd', respectively.
  634 --
  635 -- Call sites should consider whether they really want to look at the
  636 -- 'SubDemand' of an absent demand and match on 'AbsDmd' and/or 'BotDmd'
  637 -- otherwise. Really, any other 'SubDemand' would be allowed and
  638 -- might work better, depending on context.
  639 pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand
  640 pattern n :* sd <- (viewDmdPair -> (n, sd)) where
  641   C_10 :* sd = BotDmd & assertPpr (sd == botSubDmd) (text "B /=" <+> ppr sd)
  642   C_00 :* sd = AbsDmd & assertPpr (sd == seqSubDmd) (text "A /=" <+> ppr sd)
  643   n    :* sd = D n sd & assertPpr (isCardNonAbs n)  (ppr n $$ ppr sd)
  644 {-# COMPLETE (:*) #-}
  645 
  646 -- | A sub-demand describes an /evaluation context/, e.g. how deep the
  647 -- denoted thing is evaluated. See 'Demand' for examples.
  648 --
  649 -- The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call.
  650 -- E.g. The expression @f 1 2 + f 3 4@ puts call demand @SCS(C1(L))@ on @f@:
  651 -- @f@ is called exactly twice (@S@), each time exactly once (@1@) with an
  652 -- additional argument.
  653 --
  654 -- The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/:
  655 -- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that
  656 -- the denoted sub-expression is used once in the entire evaluation context
  657 -- described by the surrounding 'Demand'. E.g., @LP(ML)@ means that the
  658 -- field of the denoted expression is used at most once, although the
  659 -- entire expression might be used many times.
  660 --
  661 -- See Note [Call demands are relative]
  662 -- and Note [Demand notation].
  663 -- See also Note [Why Boxity in SubDemand and not in Demand?].
  664 data SubDemand
  665   = Poly !Boxity !CardNonOnce
  666   -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep,
  667   -- with the specified cardinality at every level. The 'Boxity' applies only
  668   -- to the outer evaluation context; inner evaluation context can be regarded
  669   -- as 'Boxed'. See Note [Boxity in Poly] for why we want it to carry 'Boxity'.
  670   -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'.
  671   --
  672   -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly Boxed n, ...]@
  673   -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites.
  674   --
  675   -- In Note [Demand notation]: @L  === P(L,L,...)@  and @L  === CL(L)@,
  676   --                            @B  === P(B,B,...)@  and @B  === CB(B)@,
  677   --                            @!A === !P(A,A,...)@ and @!A === !CA(A)@,
  678   --                            and so on.
  679   --
  680   -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes
  681   -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the
  682   -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'.
  683   | Call !CardNonAbs !SubDemand
  684   -- ^ @Call n sd@ describes the evaluation context of @n@ function
  685   -- applications, where every individual result is evaluated according to @sd@.
  686   -- @sd@ is /relative/ to a single call, see Note [Call demands are relative].
  687   -- That Note also explains why it doesn't make sense for @n@ to be absent,
  688   -- hence we forbid it with 'CardNonAbs'. Absent call demands can still be
  689   -- expressed with 'Poly'.
  690   -- Used only for values of function type. Use the smart constructor 'mkCall'
  691   -- whenever possible!
  692   | Prod !Boxity ![Demand]
  693   -- ^ @Prod b ds@ describes the evaluation context of a case scrutinisation
  694   -- on an expression of product type, where the product components are
  695   -- evaluated according to @ds@. The 'Boxity' @b@ says whether or not the box
  696   -- of the product was used.
  697 
  698 -- | We have to respect Poly rewrites through 'viewCall' and 'viewProd'.
  699 instance Eq SubDemand where
  700   d1 == d2 = case d1 of
  701     Prod b1 ds1
  702       | Just (b2, ds2) <- viewProd (length ds1) d2 -> b1 == b2 && ds1 == ds2
  703     Call n1 sd1
  704       | Just (n2, sd2) <- viewCall d2              -> n1 == n2 && sd1 == sd2
  705     Poly b1 n1
  706       | Poly b2 n2 <- d2                           -> b1 == b2 && n1 == n2
  707     _                                              -> False
  708 
  709 topSubDmd, botSubDmd, seqSubDmd :: SubDemand
  710 topSubDmd = Poly   Boxed C_0N
  711 botSubDmd = Poly Unboxed C_10
  712 seqSubDmd = Poly Unboxed C_00
  713 
  714 -- | The uniform field demand when viewing a 'Poly' as a 'Prod', as in
  715 -- 'viewProd'.
  716 polyFieldDmd :: CardNonOnce -> Demand
  717 polyFieldDmd C_00 = AbsDmd
  718 polyFieldDmd C_10 = BotDmd
  719 polyFieldDmd C_0N = topDmd
  720 polyFieldDmd n    = C_1N :* Poly Boxed C_1N & assertPpr (isCardNonOnce n) (ppr n)
  721 
  722 -- | A smart constructor for 'Prod', applying rewrite rules along the semantic
  723 -- equality @Prod b [n :* Poly Boxed n, ...] === Poly b n@, simplifying to
  724 -- 'Poly' 'SubDemand's when possible. Examples:
  725 --
  726 --   * Rewrites @P(L,L)@ (e.g., arguments @Boxed@, @[L,L]@) to @L@
  727 --   * Rewrites @!P(L,L)@ (e.g., arguments @Unboxed@, @[L,L]@) to @!L@
  728 --   * Does not rewrite @P(1L)@, @P(L!L)@ or @P(L,A)@
  729 --
  730 mkProd :: Boxity -> [Demand] -> SubDemand
  731 mkProd b ds
  732   | all (== AbsDmd) ds = Poly b C_00
  733   | all (== BotDmd) ds = Poly b C_10
  734   | dmd@(n :* Poly Boxed m):_ <- ds  -- don't rewrite P(L!L)
  735   , n == m                           -- don't rewrite P(1L)
  736   , all (== dmd) ds                  -- don't rewrite P(L,A)
  737   = Poly b n
  738   | otherwise          = Prod b ds
  739 
  740 -- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly'
  741 -- demands as necessary.
  742 viewProd :: Arity -> SubDemand -> Maybe (Boxity, [Demand])
  743 -- It's quite important that this function is optimised well;
  744 -- it is used by lubSubDmd and plusSubDmd.
  745 viewProd n (Prod b ds)
  746   | ds `lengthIs` n = Just (b, ds)
  747 -- Note the strict application to replicate: This makes sure we don't allocate
  748 -- a thunk for it, inlines it and lets case-of-case fire at call sites.
  749 viewProd n (Poly b card)
  750   | let !ds = replicate n $! polyFieldDmd card
  751   = Just (b, ds)
  752 viewProd _ _
  753   = Nothing
  754 {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation
  755                         -- for Arity. Otherwise, #18304 bites us.
  756 
  757 -- | A smart constructor for 'Call', applying rewrite rules along the semantic
  758 -- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's
  759 -- when possible.
  760 mkCall :: CardNonAbs -> SubDemand -> SubDemand
  761 mkCall C_1N sd@(Poly Boxed C_1N) = sd
  762 mkCall C_0N sd@(Poly Boxed C_0N) = sd
  763 mkCall n    cd               = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $
  764                                Call n cd
  765 
  766 -- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' subdemands as
  767 -- necessary.
  768 viewCall :: SubDemand -> Maybe (Card, SubDemand)
  769 viewCall (Call n sd) = Just (n :: Card, sd)
  770 viewCall (Poly _ n)  = Just (n :: Card, Poly Boxed n)
  771 viewCall _           = Nothing
  772 
  773 topDmd, absDmd, botDmd, seqDmd :: Demand
  774 topDmd = C_0N :* topSubDmd
  775 absDmd = AbsDmd
  776 botDmd = BotDmd
  777 seqDmd = C_11 :* seqSubDmd
  778 
  779 -- | Sets 'Boxity' to 'Unboxed' for non-'Call' sub-demands.
  780 unboxSubDemand :: SubDemand -> SubDemand
  781 unboxSubDemand (Poly _ n)  = Poly Unboxed n
  782 unboxSubDemand (Prod _ ds) = mkProd Unboxed ds
  783 unboxSubDemand sd@Call{}   = sd
  784 
  785 -- | Denotes '∪' on 'SubDemand'.
  786 lubSubDmd :: SubDemand -> SubDemand -> SubDemand
  787 -- Handle botSubDmd (just an optimisation, the general case would do the same)
  788 lubSubDmd (Poly Unboxed C_10) d2                  = d2
  789 lubSubDmd d1                  (Poly Unboxed C_10) = d1
  790 -- Handle Prod
  791 lubSubDmd (Prod b1 ds1) (Poly b2 n2)
  792   | let !d = polyFieldDmd n2
  793   = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1)
  794 lubSubDmd (Prod b1 ds1) (Prod b2 ds2)
  795   | equalLength ds1 ds2
  796   = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2)
  797 -- Handle Call
  798 lubSubDmd (Call n1 sd1) sd2@(Poly _ n2)
  799   -- See Note [Call demands are relative]
  800   | isAbs n2  = mkCall (lubCard n2 n1) sd1
  801   | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 sd2)
  802 lubSubDmd (Call n1 d1)  (Call n2 d2)
  803   | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2)
  804 -- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again).
  805 lubSubDmd (Poly b1 n1)  (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2)
  806 lubSubDmd sd1@Poly{}    sd2          = lubSubDmd sd2 sd1
  807 -- Otherwise (Call `lub` Prod) return Top
  808 lubSubDmd _             _            = topSubDmd
  809 
  810 -- | Denotes '∪' on 'Demand'.
  811 lubDmd :: Demand -> Demand -> Demand
  812 lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2
  813 
  814 -- | Denotes '+' on 'SubDemand'.
  815 plusSubDmd :: SubDemand -> SubDemand -> SubDemand
  816 -- Handle seqSubDmd (just an optimisation, the general case would do the same)
  817 plusSubDmd (Poly Unboxed C_00) d2                  = d2
  818 plusSubDmd d1                  (Poly Unboxed C_00) = d1
  819 -- Handle Prod
  820 plusSubDmd (Prod b1 ds1) (Poly b2 n2)
  821   | let !d = polyFieldDmd n2
  822   = mkProd (plusBoxity b1 b2) (strictMap (plusDmd d) ds1)
  823 plusSubDmd (Prod b1 ds1) (Prod b2 ds2)
  824   | equalLength ds1 ds2
  825   = mkProd (plusBoxity b1 b2) (strictZipWith plusDmd ds1 ds2)
  826 -- Handle Call
  827 plusSubDmd (Call n1 sd1) sd2@(Poly _ n2)
  828   -- See Note [Call demands are relative]
  829   | isAbs n2  = mkCall (plusCard n2 n1) sd1
  830   | otherwise = mkCall (plusCard n2 n1) (lubSubDmd sd1 sd2)
  831 plusSubDmd (Call n1 sd1) (Call n2 sd2)
  832   | otherwise = mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2)
  833 -- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again).
  834 plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (plusBoxity b1 b2) (plusCard n1 n2)
  835 plusSubDmd sd1@Poly{}   sd2          = plusSubDmd sd2 sd1
  836 -- Otherwise (Call `lub` Prod) return Top
  837 plusSubDmd _            _            = topSubDmd
  838 
  839 -- | Denotes '+' on 'Demand'.
  840 plusDmd :: Demand -> Demand -> Demand
  841 plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2
  842 
  843 multSubDmd :: Card -> SubDemand -> SubDemand
  844 multSubDmd C_11 sd           = sd
  845 multSubDmd C_00 _            = seqSubDmd
  846 multSubDmd C_10 (Poly _ n)   = if isStrict n then botSubDmd else seqSubDmd
  847 multSubDmd C_10 (Call n _)   = if isStrict n then botSubDmd else seqSubDmd
  848 multSubDmd n    (Poly b m)   = Poly b (multCard n m)
  849 multSubDmd n    (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]
  850 multSubDmd n    (Prod b ds)  = mkProd b (strictMap (multDmd n) ds)
  851 
  852 multDmd :: Card -> Demand -> Demand
  853 -- The first two lines compute the same result as the last line, but won't
  854 -- trigger the assertion in `:*` for input like `multDmd B 1L`, which would call
  855 -- `B :* A`. We want to return `B` in these cases.
  856 multDmd C_10 (n :* _)    = if isStrict n then BotDmd else AbsDmd
  857 multDmd n    (C_10 :* _) = if isStrict n then BotDmd else AbsDmd
  858 multDmd n    (m :* sd)   = multCard n m :* multSubDmd n sd
  859 
  860 -- | Used to suppress pretty-printing of an uninformative demand
  861 isTopDmd :: Demand -> Bool
  862 isTopDmd dmd = dmd == topDmd
  863 
  864 isAbsDmd :: Demand -> Bool
  865 isAbsDmd (n :* _) = isAbs n
  866 
  867 -- | Contrast with isStrictUsedDmd. See Note [Strict demands]
  868 isStrictDmd :: Demand -> Bool
  869 isStrictDmd (n :* _) = isStrict n
  870 
  871 -- | Not absent and used strictly. See Note [Strict demands]
  872 isStrUsedDmd :: Demand -> Bool
  873 isStrUsedDmd (n :* _) = isStrict n && not (isAbs n)
  874 
  875 -- | Is the value used at most once?
  876 isUsedOnceDmd :: Demand -> Bool
  877 isUsedOnceDmd (n :* _) = isUsedOnce n
  878 
  879 -- | We try to avoid tracking weak free variable demands in strictness
  880 -- signatures for analysis performance reasons.
  881 -- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal".
  882 isWeakDmd :: Demand -> Bool
  883 isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd
  884   where
  885     -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@,
  886     -- e.g. if @thing@ is idempotent wrt. to @plus@.
  887     -- is_plus_idem_card n = plusCard n n == n
  888     is_plus_idem_card = isCardNonOnce
  889     -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd
  890     is_plus_idem_dmd AbsDmd    = True
  891     is_plus_idem_dmd BotDmd    = True
  892     is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd
  893     -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd
  894     is_plus_idem_sub_dmd (Poly _ n)  = assert (isCardNonOnce n) True
  895     is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds
  896     is_plus_idem_sub_dmd (Call n _)  = is_plus_idem_card n -- See Note [Call demands are relative]
  897 
  898 evalDmd :: Demand
  899 evalDmd = C_1N :* topSubDmd
  900 
  901 -- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@.
  902 -- Called exactly once.
  903 strictOnceApply1Dmd :: Demand
  904 strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd
  905 
  906 -- | First argument of 'GHC.Exts.atomically#': @SCS(L)@.
  907 -- Called at least once, possibly many times.
  908 strictManyApply1Dmd :: Demand
  909 strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd
  910 
  911 -- | First argument of catch#: @MCM(L)@.
  912 -- Evaluates its arg lazily, but then applies it exactly once to one argument.
  913 lazyApply1Dmd :: Demand
  914 lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd
  915 
  916 -- | Second argument of catch#: @MCM(C1(L))@.
  917 -- Calls its arg lazily, but then applies it exactly once to an additional argument.
  918 lazyApply2Dmd :: Demand
  919 lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)
  920 
  921 -- | Make a 'Demand' evaluated at-most-once.
  922 oneifyDmd :: Demand -> Demand
  923 oneifyDmd AbsDmd    = AbsDmd
  924 oneifyDmd BotDmd    = BotDmd
  925 oneifyDmd (n :* sd) = oneifyCard n :* sd
  926 
  927 -- | Make a 'Demand' evaluated at-least-once (e.g. strict).
  928 strictifyDmd :: Demand -> Demand
  929 strictifyDmd AbsDmd    = seqDmd
  930 strictifyDmd BotDmd    = BotDmd
  931 strictifyDmd (n :* sd) = plusCard C_10 n :* sd
  932 
  933 -- | If the argument is a used non-newtype dictionary, give it strict demand.
  934 -- Also split the product type & demand and recur in order to similarly
  935 -- strictify the argument's contained used non-newtype superclass dictionaries.
  936 -- We use the demand as our recursive measure to guarantee termination.
  937 strictifyDictDmd :: Type -> Demand -> Demand
  938 strictifyDictDmd ty (n :* Prod b ds)
  939   | not (isAbs n)
  940   , Just field_tys <- as_non_newtype_dict ty
  941   = C_1N :* mkProd b (zipWith strictifyDictDmd field_tys ds)
  942       -- main idea: ensure it's strict
  943   where
  944     -- | Return a TyCon and a list of field types if the given
  945     -- type is a non-newtype dictionary type
  946     as_non_newtype_dict ty
  947       | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys)
  948           <- splitDataProductType_maybe ty
  949       , not (isNewTyCon tycon)
  950       , isClassTyCon tycon
  951       = Just inst_con_arg_tys
  952       | otherwise
  953       = Nothing
  954 strictifyDictDmd _  dmd = dmd
  955 
  956 -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@.
  957 mkCalledOnceDmd :: SubDemand -> SubDemand
  958 mkCalledOnceDmd sd = mkCall C_11 sd
  959 
  960 -- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.
  961 mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand
  962 mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity
  963 
  964 -- | Peels one call level from the sub-demand, and also returns how many
  965 -- times we entered the lambda body.
  966 peelCallDmd :: SubDemand -> (Card, SubDemand)
  967 peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd)
  968 
  969 -- Peels multiple nestings of 'Call' sub-demands and also returns
  970 -- whether it was unsaturated in the form of a 'Card'inality, denoting
  971 -- how many times the lambda body was entered.
  972 -- See Note [Demands from unsaturated function calls].
  973 peelManyCalls :: Int -> SubDemand -> Card
  974 peelManyCalls 0 _                          = C_11
  975 -- See Note [Call demands are relative]
  976 peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd
  977 peelManyCalls _ _                          = C_0N
  978 
  979 -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap
  980 mkWorkerDemand :: Int -> Demand
  981 mkWorkerDemand n = C_01 :* go n
  982   where go 0 = topSubDmd
  983         go n = Call C_01 $ go (n-1)
  984 
  985 argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]]
  986 -- ^ See Note [Computing one-shot info]
  987 argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args
  988   | unsaturated_call = []
  989   | otherwise = go arg_ds
  990   where
  991     unsaturated_call = arg_ds `lengthExceeds` n_val_args
  992 
  993     go []               = []
  994     go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds
  995 
  996     -- Avoid list tail like [ [], [], [] ]
  997     cons [] [] = []
  998     cons a  as = a:as
  999 
 1000 argOneShots :: Demand          -- ^ depending on saturation
 1001             -> [OneShotInfo]
 1002 -- ^ See Note [Computing one-shot info]
 1003 argOneShots AbsDmd    = [] -- This defn conflicts with 'saturatedByOneShots',
 1004 argOneShots BotDmd    = [] -- according to which we should return
 1005                            -- @repeat OneShotLam@ here...
 1006 argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative]
 1007   where
 1008     go (Call n sd)
 1009       | isUsedOnce n = OneShotLam    : go sd
 1010       | otherwise    = NoOneShotInfo : go sd
 1011     go _    = []
 1012 
 1013 -- |
 1014 -- @saturatedByOneShots n CM(CM(...)) = True@
 1015 --   <=>
 1016 -- There are at least n nested CM(..) calls.
 1017 -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap
 1018 saturatedByOneShots :: Int -> Demand -> Bool
 1019 saturatedByOneShots _ AbsDmd    = True
 1020 saturatedByOneShots _ BotDmd    = True
 1021 saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd)
 1022 
 1023 {- Note [Strict demands]
 1024 ~~~~~~~~~~~~~~~~~~~~~~~~
 1025 'isStrUsedDmd' returns true only of demands that are
 1026    both strict
 1027    and  used
 1028 
 1029 In particular, it is False for <B> (i.e. strict and not used,
 1030 cardinality C_10), which can and does arise in, say (#7319)
 1031    f x = raise# <some exception>
 1032 Then 'x' is not used, so f gets strictness <B> -> .
 1033 Now the w/w generates
 1034    fx = let x <B> = absentError "unused"
 1035         in raise <some exception>
 1036 At this point we really don't want to convert to
 1037    fx = case absentError "unused" of x -> raise <some exception>
 1038 Since the program is going to diverge, this swaps one error for another,
 1039 but it's really a bad idea to *ever* evaluate an absent argument.
 1040 In #7319 we get
 1041    T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]
 1042 
 1043 Note [Call demands are relative]
 1044 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1045 The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand
 1046 @LCL(C1(P(L)))@, meaning
 1047 
 1048   "f is called multiple times or not at all (CL), but each time it
 1049    is called, it's called with *exactly one* (C1) more argument.
 1050    Whenever it is called with two arguments, we have no info on how often
 1051    the field of the product result is used (L)."
 1052 
 1053 So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call.
 1054 And that extends to the information we have how its results are used in each
 1055 call site. Consider (#18903)
 1056 
 1057   h :: Int -> Int
 1058   h m =
 1059     let g :: Int -> (Int,Int)
 1060         g 1 = (m, 0)
 1061         g n = (2 * n, 2 `div` n)
 1062         {-# NOINLINE g #-}
 1063     in case m of
 1064       1 -> 0
 1065       2 -> snd (g m)
 1066       _ -> uncurry (+) (g m)
 1067 
 1068 We want to give @g@ the demand @MCM(P(MP(L),1P(L)))@, so we see that in each call
 1069 site of @g@, we are strict in the second component of the returned pair.
 1070 
 1071 This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd'
 1072 in 'plusSubDmd', but if you do the math it's just the right thing.
 1073 
 1074 There's one more subtlety: Since the nested demand is relative to exactly one
 1075 call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise
 1076 is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures
 1077 that @g@ above actually gets the @1P(L)@ demand on its second pair component,
 1078 rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand.
 1079 
 1080 Note [Computing one-shot info]
 1081 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1082 Consider a call
 1083     f (\pqr. e1) (\xyz. e2) e3
 1084 where f has usage signature
 1085     <CM(CL(CM(L)))><CM(L)><L>
 1086 Then argsOneShots returns a [[OneShotInfo]] of
 1087     [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]
 1088 The occurrence analyser propagates this one-shot infor to the
 1089 binders \pqr and \xyz;
 1090 see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal".
 1091 
 1092 Note [Boxity in Poly]
 1093 ~~~~~~~~~~~~~~~~~~~~~
 1094 To support Note [Boxity analysis], it makes sense that 'Prod' carries a
 1095 'Boxity'. But why does 'Poly' have to carry a 'Boxity', too? Shouldn't all
 1096 'Poly's be 'Boxed'? Couldn't we simply use 'Prod Unboxed' when we need to
 1097 express an unboxing demand?
 1098 
 1099 'botSubDmd' (B) needs to be the bottom of the lattice, so it needs to be an
 1100 Unboxed demand. Similarly, 'seqSubDmd' (A) is an Unboxed demand.
 1101 So why not say that Polys with absent cardinalities have Unboxed boxity?
 1102 That doesn't work, because we also need the boxed equivalents. Here's an example
 1103 for A (function 'absent' in T19871):
 1104 ```
 1105 f _ True  = 1
 1106 f a False = a `seq` 2
 1107   -- demand on a: MA, the A is short for `Poly Boxed C_00`
 1108 
 1109 g a = a `seq` f a True
 1110   -- demand on a: SA, which is `Poly Boxed C_00`
 1111 
 1112 h True  p       = g p -- SA on p (inherited from g)
 1113 h False p@(x,y) = x+y -- S!P(1!L,1!L) on p
 1114 ```
 1115 (Caveat: Since Unboxed wins in lubBoxity, we'll unbox here anyway.)
 1116 If A is treated as Unboxed, we get reboxing in the call site to 'g'.
 1117 So we obviously would need a Boxed variant of A. Rather than introducing a lot
 1118 of special cases, we just carry the Boxity in 'Poly'. Plus, we could most likely
 1119 find examples like the above for any other cardinality.
 1120 
 1121 Note [Why Boxity in SubDemand and not in Demand?]
 1122 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1123 In #19871, we started out by storing 'Boxity' in 'SubDemand', in the 'Prod'
 1124 constructor only. But then we found that we weren't able to express the unboxing
 1125 'seqSubDmd', because that one really is a `Poly C_00` sub-demand.
 1126 We then tried to store the Boxity in 'Demand' instead, for these reasons:
 1127 
 1128   1. The whole boxity-of-seq business comes to a satisfying conclusion
 1129   2. Putting Boxity in the SubDemand is weird to begin with, because it
 1130      describes the box and not its fields, just as the evaluation cardinality
 1131      of a Demand describes how often the box is used. It makes more sense that
 1132      Card and Boxity travel together. Also the alternative would have been to
 1133      store Boxity with Poly, which is even weirder and more redundant.
 1134 
 1135 But then we regressed in T7837 (grep #19871 for boring specifics), which needed
 1136 to transfer an ambient unboxed *demand* on a dictionary selector to its argument
 1137 dictionary, via a 'Call' sub-demand `C1(sd)`, as
 1138 Note [Demand transformer for a dictionary selector] explains. Annoyingly,
 1139 the boxity info has to be stored in the *sub-demand* `sd`! There's no demand
 1140 to store the boxity in. So we bit the bullet and now we store Boxity in
 1141 'SubDemand', both in 'Prod' *and* 'Poly'. See also Note [Boxity in Poly].
 1142 -}
 1143 
 1144 {- *********************************************************************
 1145 *                                                                      *
 1146                  Divergence: Whether evaluation surely diverges
 1147 *                                                                      *
 1148 ********************************************************************* -}
 1149 
 1150 -- | 'Divergence' characterises whether something surely diverges.
 1151 -- Models a subset lattice of the following exhaustive set of divergence
 1152 -- results:
 1153 --
 1154 -- [n] nontermination (e.g. loops)
 1155 -- [i] throws imprecise exception
 1156 -- [p] throws precise exceTtion
 1157 -- [c] converges (reduces to WHNF).
 1158 --
 1159 -- The different lattice elements correspond to different subsets, indicated by
 1160 -- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an
 1161 -- exception, and may or may not reduce to WHNF).
 1162 --
 1163 -- @
 1164 --             Dunno (nipc)
 1165 --                  |
 1166 --            ExnOrDiv (nip)
 1167 --                  |
 1168 --            Diverges (ni)
 1169 -- @
 1170 --
 1171 -- As you can see, we don't distinguish __n__ and __i__.
 1172 -- See Note [Precise exceptions and strictness analysis] for why __p__ is so
 1173 -- special compared to __i__.
 1174 data Divergence
 1175   = Diverges -- ^ Definitely throws an imprecise exception or diverges.
 1176   | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise
 1177              --   exception or diverges. Never converges, hence 'isDeadEndDiv'!
 1178              --   See scenario 1 in Note [Precise exceptions and strictness analysis].
 1179   | Dunno    -- ^ Might diverge, throw any kind of exception or converge.
 1180   deriving Eq
 1181 
 1182 lubDivergence :: Divergence -> Divergence -> Divergence
 1183 lubDivergence Diverges div      = div
 1184 lubDivergence div      Diverges = div
 1185 lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv
 1186 lubDivergence _        _        = Dunno
 1187 -- This needs to commute with defaultFvDmd, i.e.
 1188 -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2
 1189 -- (See Note [Default demand on free variables and arguments] for why)
 1190 
 1191 -- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'
 1192 -- needs to be symmetric.
 1193 -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@.
 1194 -- But that regresses in too many places (every infinite loop, basically) to be
 1195 -- worth it and is only relevant in higher-order scenarios
 1196 -- (e.g. Divergence of @f (throwIO blah)@).
 1197 -- So 'plusDivergence' currently is 'glbDivergence', really.
 1198 plusDivergence :: Divergence -> Divergence -> Divergence
 1199 plusDivergence Dunno    Dunno    = Dunno
 1200 plusDivergence Diverges _        = Diverges
 1201 plusDivergence _        Diverges = Diverges
 1202 plusDivergence _        _        = ExnOrDiv
 1203 
 1204 -- | In a non-strict scenario, we might not force the Divergence, in which case
 1205 -- we might converge, hence Dunno.
 1206 multDivergence :: Card -> Divergence -> Divergence
 1207 multDivergence n _ | not (isStrict n) = Dunno
 1208 multDivergence _ d                    = d
 1209 
 1210 topDiv, exnDiv, botDiv :: Divergence
 1211 topDiv = Dunno
 1212 exnDiv = ExnOrDiv
 1213 botDiv = Diverges
 1214 
 1215 -- | True if the 'Divergence' indicates that evaluation will not return.
 1216 -- See Note [Dead ends].
 1217 isDeadEndDiv :: Divergence -> Bool
 1218 isDeadEndDiv Diverges = True
 1219 isDeadEndDiv ExnOrDiv = True
 1220 isDeadEndDiv Dunno    = False
 1221 
 1222 -- See Notes [Default demand on free variables and arguments]
 1223 -- and Scenario 1 in [Precise exceptions and strictness analysis]
 1224 defaultFvDmd :: Divergence -> Demand
 1225 defaultFvDmd Dunno    = absDmd
 1226 defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv!
 1227 defaultFvDmd Diverges = botDmd -- Diverges
 1228 
 1229 defaultArgDmd :: Divergence -> Demand
 1230 -- TopRes and BotRes are polymorphic, so that
 1231 --      BotRes === (Bot -> BotRes) === ...
 1232 --      TopRes === (Top -> TopRes) === ...
 1233 -- This function makes that concrete
 1234 -- Also see Note [Default demand on free variables and arguments]
 1235 defaultArgDmd Dunno    = topDmd
 1236 -- NB: not botDmd! We don't want to mask the precise exception by forcing the
 1237 -- argument. But it is still absent.
 1238 defaultArgDmd ExnOrDiv = absDmd
 1239 defaultArgDmd Diverges = botDmd
 1240 
 1241 {- Note [Precise vs imprecise exceptions]
 1242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1243 An exception is considered to be /precise/ when it is thrown by the 'raiseIO#'
 1244 primop. It follows that all other primops (such as 'raise#' or
 1245 division-by-zero) throw /imprecise/ exceptions. Note that the actual type of
 1246 the exception thrown doesn't have any impact!
 1247 
 1248 GHC undertakes some effort not to apply an optimisation that would mask a
 1249 /precise/ exception with some other source of nontermination, such as genuine
 1250 divergence or an imprecise exception, so that the user can reliably
 1251 intercept the precise exception with a catch handler before and after
 1252 optimisations.
 1253 
 1254 See also the wiki page on precise exceptions:
 1255 https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions
 1256 Section 5 of "Tackling the awkward squad" talks about semantic concerns.
 1257 Imprecise exceptions are actually more interesting than precise ones (which are
 1258 fairly standard) from the perspective of semantics. See the paper "A Semantics
 1259 for Imprecise Exceptions" for more details.
 1260 
 1261 Note [Dead ends]
 1262 ~~~~~~~~~~~~~~~~
 1263 We call an expression that either diverges or throws a precise or imprecise
 1264 exception a "dead end". We used to call such an expression just "bottoming",
 1265 but with the measures we take to preserve precise exception semantics
 1266 (see Note [Precise exceptions and strictness analysis]), that is no longer
 1267 accurate: 'exnDiv' is no longer the bottom of the Divergence lattice.
 1268 
 1269 Yet externally to demand analysis, we mostly care about being able to drop dead
 1270 code etc., which is all due to the property that such an expression never
 1271 returns, hence we consider throwing a precise exception to be a dead end.
 1272 See also 'isDeadEndDiv'.
 1273 
 1274 Note [Precise exceptions and strictness analysis]
 1275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1276 We have to take care to preserve precise exception semantics in strictness
 1277 analysis (#17676). There are two scenarios that need careful treatment.
 1278 
 1279 The fixes were discussed at
 1280 https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions
 1281 
 1282 Recall that raiseIO# raises a *precise* exception, in contrast to raise# which
 1283 raises an *imprecise* exception. See Note [Precise vs imprecise exceptions].
 1284 
 1285 Scenario 1: Precise exceptions in case alternatives
 1286 ---------------------------------------------------
 1287 Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv.
 1288 Here's why. Consider this example from #13380 (similarly #17676):
 1289   f x y | x>0       = raiseIO# Exc
 1290         | y>0       = return 1
 1291         | otherwise = return 2
 1292 Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and
 1293 loose with the precise exception; after optimisation, (f 42 (error "boom"))
 1294 turns from throwing the precise Exc to throwing the imprecise user error
 1295 "boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be
 1296 achieved by giving it divergence exnDiv.
 1297 See Note [Default demand on free variables and arguments].
 1298 
 1299 Why don't we just give it topDiv instead of introducing exnDiv?
 1300 Because then the simplifier will fail to discard raiseIO#'s continuation in
 1301   case raiseIO# x s of { (# s', r #) -> <BIG> }
 1302 which we'd like to optimise to
 1303   case raiseIO# x s of {}
 1304 Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and
 1305 its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it
 1306 behaves exactly as botDiv, so that dead code elimination works as expected.
 1307 This is tracked by T13380b.
 1308 
 1309 Scenario 2: Precise exceptions in case scrutinees
 1310 -------------------------------------------------
 1311 Consider (more complete examples in #148, #1592, testcase strun003)
 1312 
 1313   case foo x s of { (# s', r #) -> y }
 1314 
 1315 Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception
 1316 (ultimately via raiseIO#), then we must not force 'y', which may fail to
 1317 terminate or throw an imprecise exception, until we have performed @foo x s@.
 1318 
 1319 So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to
 1320 model the exceptional control flow) when @foo x s@ may throw a precise
 1321 exception. Motivated by T13380{d,e,f}.
 1322 See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal".
 1323 
 1324 We have to be careful not to discard dead-end Divergence from case
 1325 alternatives, though (#18086):
 1326 
 1327   m = putStrLn "foo" >> error "bar"
 1328 
 1329 'm' should still have 'exnDiv', which is why it is not sufficient to lub with
 1330 'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.
 1331 
 1332 Historical Note: This used to be called the "IO hack". But that term is rather
 1333 a bad fit because
 1334 1. It's easily confused with the "State hack", which also affects IO.
 1335 2. Neither "IO" nor "hack" is a good description of what goes on here, which
 1336    is deferring strictness results after possibly throwing a precise exception.
 1337    The "hack" is probably not having to defer when we can prove that the
 1338    expression may not throw a precise exception (increasing precision of the
 1339    analysis), but that's just a favourable guess.
 1340 
 1341 Note [Exceptions and strictness]
 1342 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1343 We used to smart about catching exceptions, but we aren't anymore.
 1344 See #14998 for the way it's resolved at the moment.
 1345 
 1346 Here's a historic breakdown:
 1347 
 1348 Apparently, exception handling prim-ops didn't use to have any special
 1349 strictness signatures, thus defaulting to nopSig, which assumes they use their
 1350 arguments lazily. Joachim was the first to realise that we could provide richer
 1351 information. Thus, in 0558911f91c (Dec 13), he added signatures to
 1352 primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call
 1353 their argument, which is useful information for usage analysis. Still with a
 1354 'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.
 1355 
 1356 In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a
 1357 'strictApply1Dmd' leads to substantial performance gains. That was at the cost
 1358 of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in
 1359 28638dfe79e (Dec 15).
 1360 
 1361 Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,
 1362 Ben opened #11222. Simon made the demand analyser "understand catch" in
 1363 9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call
 1364 its argument strictly, but also swallow any thrown exceptions in
 1365 'multDivergence'. This was realized by extending the 'Str' constructor of
 1366 'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and
 1367 adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element
 1368 between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,
 1369 so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).
 1370 
 1371 This left the other variants like 'catchRetry#' having 'catchArgDmd', which is
 1372 where #14998 picked up. Item 1 was concerned with measuring the impact of also
 1373 making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that
 1374 there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7
 1375 (Apr 18). There was a lot of dead code resulting from that change, that we
 1376 removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and
 1377 removed any code that was dealing with the peculiarities.
 1378 
 1379 Where did the speed-ups vanish to? In #14998, item 3 established that
 1380 turning 'catch#' strict in its first argument didn't bring back any of the
 1381 alleged performance benefits. Item 2 of that ticket finally found out that it
 1382 was entirely due to 'catchException's new (since #11555) definition, which
 1383 was simply
 1384 
 1385     catchException !io handler = catch io handler
 1386 
 1387 While 'catchException' is arguably the saner semantics for 'catch', it is an
 1388 internal helper function in "GHC.IO". Its use in
 1389 "GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:
 1390 Remove the bang and you find the regressions we originally wanted to avoid with
 1391 'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".
 1392 
 1393 So history keeps telling us that the only possibly correct strictness annotation
 1394 for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really
 1395 is not strict in its argument: Just try this in GHCi
 1396 
 1397   :set -XScopedTypeVariables
 1398   import Control.Exception
 1399   catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")
 1400 
 1401 Any analysis that assumes otherwise will be broken in some way or another
 1402 (beyond `-fno-pendantic-bottoms`).
 1403 
 1404 But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a
 1405 subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is
 1406 only used by `raiseIO#` in order to preserve precise exceptions by strictness
 1407 analysis, while not impacting the ability to eliminate dead code.
 1408 See Note [Precise exceptions and strictness analysis].
 1409 
 1410 Note [Default demand on free variables and arguments]
 1411 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1412 Free variables not mentioned in the environment of a 'DmdType'
 1413 are demanded according to the demand type's Divergence:
 1414   * In a Diverges (botDiv) context, that demand is botDmd
 1415     (strict and absent).
 1416   * In all other contexts, the demand is absDmd (lazy and absent).
 1417 This is recorded in 'defaultFvDmd'.
 1418 
 1419 Similarly, we can eta-expand demand types to get demands on excess arguments
 1420 not accounted for in the type, by consulting 'defaultArgDmd':
 1421   * In a Diverges (botDiv) context, that demand is again botDmd.
 1422   * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge
 1423     before evaluating the excess argument, but don't want to eagerly evaluate
 1424     it (cf. Note [Precise exceptions and strictness analysis]).
 1425   * In a Dunno context (topDiv), the demand is topDmd, because
 1426     it's perfectly possible to enter the additional lambda and evaluate it
 1427     in unforeseen ways (so, not absent).
 1428 
 1429 Note [Bottom CPR iff Dead-Ending Divergence]
 1430 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1431 Both CPR analysis and Demand analysis handle recursive functions by doing
 1432 fixed-point iteration. To find the *least* (e.g., most informative) fixed-point,
 1433 iteration starts with the bottom element of the semantic domain. Diverging
 1434 functions generally have the bottom element as their least fixed-point.
 1435 
 1436 One might think that CPR analysis and Demand analysis then agree in when a
 1437 function gets a bottom denotation. E.g., whenever it has 'botCpr', it should
 1438 also have 'botDiv'. But that is not the case, because strictness analysis has to
 1439 be careful around precise exceptions, see Note [Precise vs imprecise exceptions].
 1440 
 1441 So Demand analysis gives some diverging functions 'exnDiv' (which is *not* the
 1442 bottom element) when the CPR signature says 'botCpr', and that's OK. Here's an
 1443 example (from #18086) where that is the case:
 1444 
 1445 ioTest :: IO ()
 1446 ioTest = do
 1447   putStrLn "hi"
 1448   undefined
 1449 
 1450 However, one can loosely say that we give a function 'botCpr' whenever its
 1451 'Divergence' is 'exnDiv' or 'botDiv', i.e., dead-ending. But that's just
 1452 a consequence of fixed-point iteration, it's not important that they agree.
 1453 
 1454 ************************************************************************
 1455 *                                                                      *
 1456            Demand environments and types
 1457 *                                                                      *
 1458 ************************************************************************
 1459 -}
 1460 
 1461 -- Subject to Note [Default demand on free variables and arguments]
 1462 type DmdEnv = VarEnv Demand
 1463 
 1464 emptyDmdEnv :: DmdEnv
 1465 emptyDmdEnv = emptyVarEnv
 1466 
 1467 multDmdEnv :: Card -> DmdEnv -> DmdEnv
 1468 multDmdEnv C_11 env = env
 1469 multDmdEnv C_00 _   = emptyDmdEnv
 1470 multDmdEnv n    env = mapVarEnv (multDmd n) env
 1471 
 1472 reuseEnv :: DmdEnv -> DmdEnv
 1473 reuseEnv = multDmdEnv C_1N
 1474 
 1475 -- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have
 1476 -- /some/ usage in the returned demand types -- they are not Absent.
 1477 -- See Note [Absence analysis for stable unfoldings and RULES]
 1478 --     in "GHC.Core.Opt.DmdAnal".
 1479 keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv
 1480 keepAliveDmdEnv env vs
 1481   = nonDetStrictFoldVarSet add env vs
 1482   where
 1483     add :: Id -> DmdEnv -> DmdEnv
 1484     add v env = extendVarEnv_C add_dmd env v topDmd
 1485 
 1486     add_dmd :: Demand -> Demand -> Demand
 1487     -- If the existing usage is Absent, make it used
 1488     -- Otherwise leave it alone
 1489     add_dmd dmd _ | isAbsDmd dmd = topDmd
 1490                   | otherwise    = dmd
 1491 
 1492 -- | Characterises how an expression
 1493 --    * Evaluates its free variables ('dt_env')
 1494 --    * Evaluates its arguments ('dt_args')
 1495 --    * Diverges on every code path or not ('dt_div')
 1496 data DmdType
 1497   = DmdType
 1498   { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables
 1499   , dt_args :: ![Demand]   -- ^ Demand on arguments
 1500   , dt_div  :: !Divergence -- ^ Whether evaluation diverges.
 1501                           -- See Note [Demand type Divergence]
 1502   }
 1503 
 1504 instance Eq DmdType where
 1505   (==) (DmdType fv1 ds1 div1)
 1506        (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2
 1507          -- It's OK to use nonDetUFMToList here because we're testing for
 1508          -- equality and even though the lists will be in some arbitrary
 1509          -- Unique order, it is the same order for both
 1510                               && ds1 == ds2 && div1 == div2
 1511 
 1512 -- | Compute the least upper bound of two 'DmdType's elicited /by the same
 1513 -- incoming demand/!
 1514 lubDmdType :: DmdType -> DmdType -> DmdType
 1515 lubDmdType d1 d2
 1516   = DmdType lub_fv lub_ds lub_div
 1517   where
 1518     n = max (dmdTypeDepth d1) (dmdTypeDepth d2)
 1519     (DmdType fv1 ds1 r1) = etaExpandDmdType n d1
 1520     (DmdType fv2 ds2 r2) = etaExpandDmdType n d2
 1521 
 1522     lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)
 1523     lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2
 1524     lub_div = lubDivergence r1 r2
 1525 
 1526 type PlusDmdArg = (DmdEnv, Divergence)
 1527 
 1528 mkPlusDmdArg :: DmdEnv -> PlusDmdArg
 1529 mkPlusDmdArg env = (env, topDiv)
 1530 
 1531 toPlusDmdArg :: DmdType -> PlusDmdArg
 1532 toPlusDmdArg (DmdType fv _ r) = (fv, r)
 1533 
 1534 plusDmdType :: DmdType -> PlusDmdArg -> DmdType
 1535 plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)
 1536     -- See Note [Asymmetry of 'plus*']
 1537     -- 'plus' takes the argument/result info from its *first* arg,
 1538     -- using its second arg just for its free-var info.
 1539   | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd
 1540   = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient
 1541   | otherwise
 1542   = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))
 1543             ds1
 1544             (r1 `plusDivergence` t2)
 1545 
 1546 botDmdType :: DmdType
 1547 botDmdType = DmdType emptyDmdEnv [] botDiv
 1548 
 1549 -- | The demand type of doing nothing (lazy, absent, no Divergence
 1550 -- information). Note that it is ''not'' the top of the lattice (which would be
 1551 -- "may use everything"), so it is (no longer) called topDmdType.
 1552 nopDmdType :: DmdType
 1553 nopDmdType = DmdType emptyDmdEnv [] topDiv
 1554 
 1555 isTopDmdType :: DmdType -> Bool
 1556 isTopDmdType (DmdType env args div)
 1557   = div == topDiv && null args && isEmptyVarEnv env
 1558 
 1559 -- | The demand type of an unspecified expression that is guaranteed to
 1560 -- throw a (precise or imprecise) exception or diverge.
 1561 exnDmdType :: DmdType
 1562 exnDmdType = DmdType emptyDmdEnv [] exnDiv
 1563 
 1564 dmdTypeDepth :: DmdType -> Arity
 1565 dmdTypeDepth = length . dt_args
 1566 
 1567 -- | This makes sure we can use the demand type with n arguments after eta
 1568 -- expansion, where n must not be lower than the demand types depth.
 1569 -- It appends the argument list with the correct 'defaultArgDmd'.
 1570 etaExpandDmdType :: Arity -> DmdType -> DmdType
 1571 etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}
 1572   | n == depth = d
 1573   | n >  depth = d{dt_args = inc_ds}
 1574   | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)
 1575   where depth = length ds
 1576         -- Arity increase:
 1577         --  * Demands on FVs are still valid
 1578         --  * Demands on args also valid, plus we can extend with defaultArgDmd
 1579         --    as appropriate for the given Divergence
 1580         --  * Divergence is still valid:
 1581         --    - A dead end after 2 arguments stays a dead end after 3 arguments
 1582         --    - The remaining case is Dunno, which is already topDiv
 1583         inc_ds = take n (ds ++ repeat (defaultArgDmd div))
 1584 
 1585 -- | A conservative approximation for a given 'DmdType' in case of an arity
 1586 -- decrease. Currently, it's just nopDmdType.
 1587 decreaseArityDmdType :: DmdType -> DmdType
 1588 decreaseArityDmdType _ = nopDmdType
 1589 
 1590 splitDmdTy :: DmdType -> (Demand, DmdType)
 1591 -- Split off one function argument
 1592 -- We already have a suitable demand on all
 1593 -- free vars, so no need to add more!
 1594 splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})
 1595 splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)
 1596 
 1597 multDmdType :: Card -> DmdType -> DmdType
 1598 multDmdType n (DmdType fv args res_ty)
 1599   = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $
 1600     DmdType (multDmdEnv n fv)
 1601             (map (multDmd n) args)
 1602             (multDivergence n res_ty)
 1603 
 1604 peelFV :: DmdType -> Var -> (DmdType, Demand)
 1605 peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
 1606                                (DmdType fv' ds res, dmd)
 1607   where
 1608   -- Force these arguments so that old `Env` is not retained.
 1609   !fv' = fv `delVarEnv` id
 1610   -- See Note [Default demand on free variables and arguments]
 1611   !dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res
 1612 
 1613 addDemand :: Demand -> DmdType -> DmdType
 1614 addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
 1615 
 1616 findIdDemand :: DmdType -> Var -> Demand
 1617 findIdDemand (DmdType fv _ res) id
 1618   = lookupVarEnv fv id `orElse` defaultFvDmd res
 1619 
 1620 -- | When e is evaluated after executing an IO action that may throw a precise
 1621 -- exception, we act as if there is an additional control flow path that is
 1622 -- taken if e throws a precise exception. The demand type of this control flow
 1623 -- path
 1624 --   * is lazy and absent ('topDmd') in all free variables and arguments
 1625 --   * has 'exnDiv' 'Divergence' result
 1626 -- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.
 1627 -- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!
 1628 -- That means failure to drop dead-ends, see #18086.
 1629 -- See Note [Precise exceptions and strictness analysis]
 1630 deferAfterPreciseException :: DmdType -> DmdType
 1631 deferAfterPreciseException = lubDmdType exnDmdType
 1632 
 1633 -- | See 'keepAliveDmdEnv'.
 1634 keepAliveDmdType :: DmdType -> VarSet -> DmdType
 1635 keepAliveDmdType (DmdType fvs ds res) vars =
 1636   DmdType (fvs `keepAliveDmdEnv` vars) ds res
 1637 
 1638 {-
 1639 Note [Demand type Divergence]
 1640 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1641 In contrast to DmdSigs, DmdTypes are elicited under a specific incoming demand.
 1642 This is described in detail in Note [Understanding DmdType and DmdSig].
 1643 Here, we'll focus on what that means for a DmdType's Divergence in a higher-order
 1644 scenario.
 1645 
 1646 Consider
 1647   err x y = x `seq` y `seq` error (show x)
 1648 this has a strictness signature of
 1649   <1L><1L>b
 1650 meaning that we don't know what happens when we call err in weaker contexts than
 1651 C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We
 1652 may not unleash the botDiv, hence assume topDiv. Of course, in
 1653 @err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see
 1654 that the expression diverges.
 1655 
 1656 Now consider a function
 1657   f g = g 1 2
 1658 with signature <C1(C1(L))>, and the expression
 1659   f err `seq` ()
 1660 now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed
 1661 on err via the App rule. In contrast to weaker head strictness, this demand is
 1662 strong enough to unleash err's signature and hence we see that the whole
 1663 expression diverges!
 1664 
 1665 Note [Asymmetry of 'plus*']
 1666 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1667 'plus' for DmdTypes is *asymmetrical*, because there can only one
 1668 be one type contributing argument demands!  For example, given (e1 e2), we get
 1669 a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do
 1670 (dt1 `plusType` dt2). Similarly with
 1671   case e of { p -> rhs }
 1672 we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then
 1673 compute (dt_rhs `plusType` dt_scrut).
 1674 
 1675 We
 1676  1. combine the information on the free variables,
 1677  2. take the demand on arguments from the first argument
 1678  3. combine the termination results, as in plusDivergence.
 1679 
 1680 Since we don't use argument demands of the second argument anyway, 'plus's
 1681 second argument is just a 'PlusDmdType'.
 1682 
 1683 But note that the argument demand types are not guaranteed to be observed in
 1684 left to right order. For example, analysis of a case expression will pass the
 1685 demand type for the alts as the left argument and the type for the scrutinee as
 1686 the right argument. Also, it is not at all clear if there is such an order;
 1687 consider the LetUp case, where the RHS might be forced at any point while
 1688 evaluating the let body.
 1689 Therefore, it is crucial that 'plusDivergence' is symmetric!
 1690 
 1691 Note [Demands from unsaturated function calls]
 1692 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1693 Consider a demand transformer d1 -> d2 -> r for f.
 1694 If a sufficiently detailed demand is fed into this transformer,
 1695 e.g <C1(C1(L))> arising from "f x1 x2" in a strict, use-once context,
 1696 then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for
 1697 the free variable environment) and furthermore the result information r is the
 1698 one we want to use.
 1699 
 1700 An anonymous lambda is also an unsaturated function all (needs one argument,
 1701 none given), so this applies to that case as well.
 1702 
 1703 But the demand fed into f might be less than C1(C1(L)). Then we have to
 1704 'multDmdType' the announced demand type. Examples:
 1705  * Not strict enough, e.g. C1(C1(L)):
 1706    - We have to multiply all argument and free variable demands with C_01,
 1707      zapping strictness.
 1708    - We have to multiply divergence with C_01. If r says that f Diverges for sure,
 1709      then this holds when the demand guarantees that two arguments are going to
 1710      be passed. If the demand is lower, we may just as well converge.
 1711      If we were tracking definite convergence, than that would still hold under
 1712      a weaker demand than expected by the demand transformer.
 1713  * Used more than once, e.g. CS(C1(L)):
 1714    - Multiply with C_1N. Even if f puts a used-once demand on any of its argument
 1715      or free variables, if we call f multiple times, we may evaluate this
 1716      argument or free variable multiple times.
 1717 
 1718 In dmdTransformSig, we call peelManyCalls to find out the 'Card'inality with
 1719 which we have to multiply and then call multDmdType with that.
 1720 
 1721 Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use
 1722 peelCallDmd, which peels only one level, but also returns the demand put on the
 1723 body of the function.
 1724 -}
 1725 
 1726 
 1727 {-
 1728 ************************************************************************
 1729 *                                                                      *
 1730                      Demand signatures
 1731 *                                                                      *
 1732 ************************************************************************
 1733 
 1734 In a let-bound Id we record its demand signature.
 1735 In principle, this demand signature is a demand transformer, mapping
 1736 a demand on the Id into a DmdType, which gives
 1737         a) the free vars of the Id's value
 1738         b) the Id's arguments
 1739         c) an indication of the result of applying
 1740            the Id to its arguments
 1741 
 1742 However, in fact we store in the Id an extremely emascuated demand
 1743 transfomer, namely
 1744 
 1745                 a single DmdType
 1746 (Nevertheless we dignify DmdSig as a distinct type.)
 1747 
 1748 This DmdType gives the demands unleashed by the Id when it is applied
 1749 to as many arguments as are given in by the arg demands in the DmdType.
 1750 Also see Note [Demand type Divergence] for the meaning of a Divergence in a
 1751 strictness signature.
 1752 
 1753 If an Id is applied to less arguments than its arity, it means that
 1754 the demand on the function at a call site is weaker than the vanilla
 1755 call demand, used for signature inference. Therefore we place a top
 1756 demand on all arguments. Otherwise, the demand is specified by Id's
 1757 signature.
 1758 
 1759 For example, the demand transformer described by the demand signature
 1760         DmdSig (DmdType {x -> <1L>} <A><1P(L,L)>)
 1761 says that when the function is applied to two arguments, it
 1762 unleashes demand 1L on the free var x, A on the first arg,
 1763 and 1P(L,L) on the second.
 1764 
 1765 If this same function is applied to one arg, all we can say is that it
 1766 uses x with 1L, and its arg with demand 1P(L,L).
 1767 
 1768 Note [Understanding DmdType and DmdSig]
 1769 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1770 Demand types are sound approximations of an expression's semantics relative to
 1771 the incoming demand we put the expression under. Consider the following
 1772 expression:
 1773 
 1774     \x y -> x `seq` (y, 2*x)
 1775 
 1776 Here is a table with demand types resulting from different incoming demands we
 1777 put that expression under. Note the monotonicity; a stronger incoming demand
 1778 yields a more precise demand type:
 1779 
 1780     incoming demand   |  demand type
 1781     --------------------------------
 1782     1A                  |  <L><L>{}
 1783     C1(C1(L))           |  <1P(L)><L>{}
 1784     C1(C1(1P(1P(L),A))) |  <1P(A)><A>{}
 1785 
 1786 Note that in the first example, the depth of the demand type was *higher* than
 1787 the arity of the incoming call demand due to the anonymous lambda.
 1788 The converse is also possible and happens when we unleash demand signatures.
 1789 In @f x y@, the incoming call demand on f has arity 2. But if all we have is a
 1790 demand signature with depth 1 for @f@ (which we can safely unleash, see below),
 1791 the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.
 1792 
 1793 So: Demand types are elicited by putting an expression under an incoming (call)
 1794 demand, the arity of which can be lower or higher than the depth of the
 1795 resulting demand type.
 1796 In contrast, a demand signature summarises a function's semantics *without*
 1797 immediately specifying the incoming demand it was produced under. Despite StrSig
 1798 being a newtype wrapper around DmdType, it actually encodes two things:
 1799 
 1800   * The threshold (i.e., minimum arity) to unleash the signature
 1801   * A demand type that is sound to unleash when the minimum arity requirement is
 1802     met.
 1803 
 1804 Here comes the subtle part: The threshold is encoded in the wrapped demand
 1805 type's depth! So in mkDmdSigForArity we make sure to trim the list of
 1806 argument demands to the given threshold arity. Call sites will make sure that
 1807 this corresponds to the arity of the call demand that elicited the wrapped
 1808 demand type. See also Note [What are demand signatures?].
 1809 -}
 1810 
 1811 -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe
 1812 -- to unleash. Better construct this through 'mkDmdSigForArity'.
 1813 -- See Note [Understanding DmdType and DmdSig]
 1814 newtype DmdSig
 1815   = DmdSig DmdType
 1816   deriving Eq
 1817 
 1818 -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig'
 1819 -- unleashable at that arity. See Note [Understanding DmdType and DmdSig].
 1820 mkDmdSigForArity :: Arity -> DmdType -> DmdSig
 1821 mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)
 1822   | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div
 1823   | otherwise                   = DmdSig (etaExpandDmdType arity dmd_ty)
 1824 
 1825 mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig
 1826 mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res)
 1827 
 1828 splitDmdSig :: DmdSig -> ([Demand], Divergence)
 1829 splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res)
 1830 
 1831 dmdSigDmdEnv :: DmdSig -> DmdEnv
 1832 dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env
 1833 
 1834 hasDemandEnvSig :: DmdSig -> Bool
 1835 hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv
 1836 
 1837 botSig :: DmdSig
 1838 botSig = DmdSig botDmdType
 1839 
 1840 nopSig :: DmdSig
 1841 nopSig = DmdSig nopDmdType
 1842 
 1843 isTopSig :: DmdSig -> Bool
 1844 isTopSig (DmdSig ty) = isTopDmdType ty
 1845 
 1846 -- | True if the signature diverges or throws an exception in a saturated call.
 1847 -- See Note [Dead ends].
 1848 isDeadEndSig :: DmdSig -> Bool
 1849 isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res
 1850 
 1851 -- | Returns true if an application to n args would diverge or throw an
 1852 -- exception.
 1853 --
 1854 -- If a function having 'botDiv' is applied to a less number of arguments than
 1855 -- its syntactic arity, we cannot say for sure that it is going to diverge.
 1856 -- Hence this function conservatively returns False in that case.
 1857 -- See Note [Dead ends].
 1858 appIsDeadEnd :: DmdSig -> Int -> Bool
 1859 appIsDeadEnd (DmdSig (DmdType _ ds res)) n
 1860   = isDeadEndDiv res && not (lengthExceeds ds n)
 1861 
 1862 prependArgsDmdSig :: Int -> DmdSig -> DmdSig
 1863 -- ^ Add extra ('topDmd') arguments to a strictness signature.
 1864 -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument
 1865 -- demands. This is used by FloatOut.
 1866 prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))
 1867   | new_args == 0       = sig
 1868   | isTopDmdType dmd_ty = sig
 1869   | new_args < 0        = pprPanic "prependArgsDmdSig: negative new_args"
 1870                                    (ppr new_args $$ ppr sig)
 1871   | otherwise           = DmdSig (DmdType env dmds' res)
 1872   where
 1873     dmds' = replicate new_args topDmd ++ dmds
 1874 
 1875 etaConvertDmdSig :: Arity -> DmdSig -> DmdSig
 1876 -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to
 1877 -- the former (when the Simplifier identifies a new join points, for example).
 1878 -- In contrast to 'prependArgsDmdSig', this /appends/ extra arg demands if
 1879 -- necessary.
 1880 -- This works by looking at the 'DmdType' (which was produced under a call
 1881 -- demand for the old arity) and trying to transfer as many facts as we can to
 1882 -- the call demand of new arity.
 1883 -- An arity increase (resulting in a stronger incoming demand) can retain much
 1884 -- of the info, while an arity decrease (a weakening of the incoming demand)
 1885 -- must fall back to a conservative default.
 1886 etaConvertDmdSig arity (DmdSig dmd_ty)
 1887   | arity < dmdTypeDepth dmd_ty = DmdSig $ decreaseArityDmdType dmd_ty
 1888   | otherwise                   = DmdSig $ etaExpandDmdType arity dmd_ty
 1889 
 1890 {-
 1891 ************************************************************************
 1892 *                                                                      *
 1893                      Demand transformers
 1894 *                                                                      *
 1895 ************************************************************************
 1896 -}
 1897 
 1898 -- | A /demand transformer/ is a monotone function from an incoming evaluation
 1899 -- context ('SubDemand') to a 'DmdType', describing how the denoted thing
 1900 -- (i.e. expression, function) uses its arguments and free variables, and
 1901 -- whether it diverges.
 1902 --
 1903 -- See Note [Understanding DmdType and DmdSig]
 1904 -- and Note [What are demand signatures?].
 1905 type DmdTransformer = SubDemand -> DmdType
 1906 
 1907 -- | Extrapolate a demand signature ('DmdSig') into a 'DmdTransformer'.
 1908 --
 1909 -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context,
 1910 -- return how the function evaluates its free variables and arguments.
 1911 dmdTransformSig :: DmdSig -> DmdTransformer
 1912 dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd
 1913   = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty
 1914     -- see Note [Demands from unsaturated function calls]
 1915     -- and Note [What are demand signatures?]
 1916 
 1917 -- | A special 'DmdTransformer' for data constructors that feeds product
 1918 -- demands into the constructor arguments.
 1919 dmdTransformDataConSig :: Arity -> DmdTransformer
 1920 dmdTransformDataConSig arity sd = case go arity sd of
 1921   Just dmds -> DmdType emptyDmdEnv dmds topDiv
 1922   Nothing   -> nopDmdType -- Not saturated
 1923   where
 1924     go 0 sd             = snd <$> viewProd arity sd
 1925     go n (Call C_11 sd) = go (n-1) sd  -- strict calls only!
 1926     go _ _              = Nothing
 1927 
 1928 -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand
 1929 -- on the result into the indicated dictionary component (if saturated).
 1930 -- See Note [Demand transformer for a dictionary selector].
 1931 dmdTransformDictSelSig :: DmdSig -> DmdTransformer
 1932 -- NB: This currently doesn't handle newtype dictionaries.
 1933 -- It should simply apply call_sd directly to the dictionary, I suppose.
 1934 dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd
 1935    | (n, sd') <- peelCallDmd call_sd
 1936    , Prod _ sig_ds <- prod
 1937    = multDmdType n $
 1938      DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv
 1939    | otherwise
 1940    = nopDmdType -- See Note [Demand transformer for a dictionary selector]
 1941   where
 1942     enhance _  AbsDmd   = AbsDmd
 1943     enhance _  BotDmd   = BotDmd
 1944     enhance sd _dmd_var = C_11 :* sd  -- This is the one!
 1945                                       -- C_11, because we multiply with n above
 1946 dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd)
 1947 
 1948 {-
 1949 Note [What are demand signatures?]
 1950 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1951 Demand analysis interprets expressions in the abstract domain of demand
 1952 transformers. Given a (sub-)demand that denotes the evaluation context, the
 1953 abstract transformer of an expression gives us back a demand type denoting
 1954 how other things (like arguments and free vars) were used when the expression
 1955 was evaluated. Here's an example:
 1956 
 1957   f x y =
 1958     if x + expensive
 1959       then \z -> z + y * ...
 1960       else \z -> z * ...
 1961 
 1962 The abstract transformer (let's call it F_e) of the if expression (let's
 1963 call it e) would transform an incoming (undersaturated!) head demand 1A into
 1964 a demand type like {x-><1L>,y-><L>}<L>. In pictures:
 1965 
 1966      Demand ---F_e---> DmdType
 1967      <1A>              {x-><1L>,y-><L>}<L>
 1968 
 1969 Let's assume that the demand transformers we compute for an expression are
 1970 correct wrt. to some concrete semantics for Core. How do demand signatures fit
 1971 in? They are strange beasts, given that they come with strict rules when to
 1972 it's sound to unleash them.
 1973 
 1974 Fortunately, we can formalise the rules with Galois connections. Consider
 1975 f's strictness signature, {}<1L><L>. It's a single-point approximation of
 1976 the actual abstract transformer of f's RHS for arity 2. So, what happens is that
 1977 we abstract *once more* from the abstract domain we already are in, replacing
 1978 the incoming Demand by a simple lattice with two elements denoting incoming
 1979 arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom
 1980 element). Here's the diagram:
 1981 
 1982      A_2 -----f_f----> DmdType
 1983       ^                   |
 1984       | α               γ |
 1985       |                   v
 1986   SubDemand --F_f----> DmdType
 1987 
 1988 With
 1989   α(C1(C1(_))) = >=2
 1990   α(_)         =  <2
 1991   γ(ty)        =  ty
 1992 and F_f being the abstract transformer of f's RHS and f_f being the abstracted
 1993 abstract transformer computable from our demand signature simply by
 1994 
 1995   f_f(>=2) = {}<1L><L>
 1996   f_f(<2)  = multDmdType C_0N {}<1L><L>
 1997 
 1998 where multDmdType makes a proper top element out of the given demand type.
 1999 
 2000 In practice, the A_n domain is not just a simple Bool, but a Card, which is
 2001 exactly the Card with which we have to multDmdType. The Card for arity n
 2002 is computed by calling @peelManyCalls n@, which corresponds to α above.
 2003 
 2004 Note [Demand transformer for a dictionary selector]
 2005 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 2006 Suppose we have a superclass selector 'sc_sel' and a class method
 2007 selector 'op_sel', and a function that uses both, like this
 2008 
 2009 -- Strictness sig: 1P(1,A)
 2010 sc_sel (x,y) = x
 2011 
 2012 -- Strictness sig: 1P(A,1)
 2013 op_sel (p,q)= q
 2014 
 2015 f d v = op_sel (sc_sel d) v
 2016 
 2017 What do we learn about the demand on 'd'?  Alas, we see only the
 2018 demand from 'sc_sel', namely '1P(1,A)'.  We /don't/ see that 'd' really has a nested
 2019 demand '1P(1P(A,1C1(1)),A)'.  On the other hand, if we inlined the two selectors
 2020 we'd have
 2021 
 2022 f d x = case d of (x,_) ->
 2023         case x of (_,q) ->
 2024         q v
 2025 
 2026 If we analyse that, we'll get a richer, nested demand on 'd'.
 2027 
 2028 We want to behave /as if/ we'd inlined 'op_sel' and 'sc_sel'. We can do this
 2029 easily by building a richer demand transformer for dictionary selectors than
 2030 is expressible by a regular demand signature.
 2031 And that is what 'dmdTransformDictSelSig' does: it transforms the demand on the
 2032 result to a demand on the (single) argument.
 2033 
 2034 How does it do that?
 2035 If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'
 2036 into the appropriate field of the dictionary. What *is* the appropriate field?
 2037 We just look at the strictness signature of the class op, which will be
 2038 something like: P(AAA1AAAAA). Then replace the '1' (or any other non-absent
 2039 demand, really) by the demand 'd'. The '1' acts as if it was a demand variable,
 2040 the whole signature really means `\d. P(AAAdAAAAA)` for any incoming
 2041 demand 'd'.
 2042 
 2043 For single-method classes, which are represented by newtypes the signature
 2044 of 'op' won't look like P(...), so matching on Prod will fail.
 2045 That's fine: if we are doing strictness analysis we are also doing inlining,
 2046 so we'll have inlined 'op' into a cast.  So we can bale out in a conservative
 2047 way, returning nopDmdType. SG: Although we then probably want to apply the eval
 2048 demand 'd' directly to 'op' rather than turning it into 'topSubDmd'...
 2049 
 2050 It is (just.. #8329) possible to be running strictness analysis *without*
 2051 having inlined class ops from single-method classes.  Suppose you are using
 2052 ghc --make; and the first module has a local -O0 flag.  So you may load a class
 2053 without interface pragmas, ie (currently) without an unfolding for the class
 2054 ops.   Now if a subsequent module in the --make sweep has a local -O flag
 2055 you might do strictness analysis, but there is no inlining for the class op.
 2056 This is weird, so I'm not worried about whether this optimises brilliantly; but
 2057 it should not fall over.
 2058 -}
 2059 
 2060 -- | Remove the demand environment from the signature.
 2061 zapDmdEnvSig :: DmdSig -> DmdSig
 2062 zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r
 2063 
 2064 zapUsageDemand :: Demand -> Demand
 2065 -- Remove the usage info, but not the strictness info, from the demand
 2066 zapUsageDemand = kill_usage $ KillFlags
 2067     { kf_abs         = True
 2068     , kf_used_once   = True
 2069     , kf_called_once = True
 2070     }
 2071 
 2072 -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the demand
 2073 zapUsedOnceDemand :: Demand -> Demand
 2074 zapUsedOnceDemand = kill_usage $ KillFlags
 2075     { kf_abs         = False
 2076     , kf_used_once   = True
 2077     , kf_called_once = False
 2078     }
 2079 
 2080 -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness
 2081 --   signature
 2082 zapUsedOnceSig :: DmdSig -> DmdSig
 2083 zapUsedOnceSig (DmdSig (DmdType env ds r))
 2084     = DmdSig (DmdType env (map zapUsedOnceDemand ds) r)
 2085 
 2086 data KillFlags = KillFlags
 2087     { kf_abs         :: Bool
 2088     , kf_used_once   :: Bool
 2089     , kf_called_once :: Bool
 2090     }
 2091 
 2092 kill_usage_card :: KillFlags -> Card -> Card
 2093 kill_usage_card kfs C_00 | kf_abs kfs       = C_0N
 2094 kill_usage_card kfs C_10 | kf_abs kfs       = C_1N
 2095 kill_usage_card kfs C_01 | kf_used_once kfs = C_0N
 2096 kill_usage_card kfs C_11 | kf_used_once kfs = C_1N
 2097 kill_usage_card _   n                       = n
 2098 
 2099 kill_usage :: KillFlags -> Demand -> Demand
 2100 kill_usage _   AbsDmd    = AbsDmd
 2101 kill_usage _   BotDmd    = BotDmd
 2102 kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd
 2103 
 2104 kill_usage_sd :: KillFlags -> SubDemand -> SubDemand
 2105 kill_usage_sd kfs (Call n sd)
 2106   | kf_called_once kfs        = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)
 2107   | otherwise                 = mkCall n                (kill_usage_sd kfs sd)
 2108 kill_usage_sd kfs (Prod b ds) = mkProd b (map (kill_usage kfs) ds)
 2109 kill_usage_sd _   sd          = sd
 2110 
 2111 {- *********************************************************************
 2112 *                                                                      *
 2113                TypeShape and demand trimming
 2114 *                                                                      *
 2115 ********************************************************************* -}
 2116 
 2117 
 2118 data TypeShape -- See Note [Trimming a demand to a type]
 2119                --     in GHC.Core.Opt.DmdAnal
 2120   = TsFun TypeShape
 2121   | TsProd [TypeShape]
 2122   | TsUnk
 2123 
 2124 trimToType :: Demand -> TypeShape -> Demand
 2125 -- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
 2126 trimToType AbsDmd    _  = AbsDmd
 2127 trimToType BotDmd    _  = BotDmd
 2128 trimToType (n :* sd) ts
 2129   = n :* go sd ts
 2130   where
 2131     go (Prod b ds) (TsProd tss)
 2132       | equalLength ds tss    = mkProd b (zipWith trimToType ds tss)
 2133     go (Call n sd) (TsFun ts) = mkCall n (go sd ts)
 2134     go sd@Poly{}   _          = sd
 2135     go _           _          = topSubDmd
 2136 
 2137 -- | Drop all boxity
 2138 trimBoxity :: Demand -> Demand
 2139 trimBoxity AbsDmd    = AbsDmd
 2140 trimBoxity BotDmd    = BotDmd
 2141 trimBoxity (n :* sd) = n :* go sd
 2142   where
 2143     go (Poly _ n)  = Poly Boxed n
 2144     go (Prod _ ds) = mkProd Boxed (map trimBoxity ds)
 2145     go (Call n sd) = mkCall n $ go sd
 2146 
 2147 {-
 2148 ************************************************************************
 2149 *                                                                      *
 2150                      'seq'ing demands
 2151 *                                                                      *
 2152 ************************************************************************
 2153 -}
 2154 
 2155 seqDemand :: Demand -> ()
 2156 seqDemand AbsDmd    = ()
 2157 seqDemand BotDmd    = ()
 2158 seqDemand (_ :* sd) = seqSubDemand sd
 2159 
 2160 seqSubDemand :: SubDemand -> ()
 2161 seqSubDemand (Prod _ ds) = seqDemandList ds
 2162 seqSubDemand (Call _ sd) = seqSubDemand sd
 2163 seqSubDemand (Poly _ _)  = ()
 2164 
 2165 seqDemandList :: [Demand] -> ()
 2166 seqDemandList = foldr (seq . seqDemand) ()
 2167 
 2168 seqDmdType :: DmdType -> ()
 2169 seqDmdType (DmdType env ds res) =
 2170   seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()
 2171 
 2172 seqDmdEnv :: DmdEnv -> ()
 2173 seqDmdEnv env = seqEltsUFM seqDemand env
 2174 
 2175 seqDmdSig :: DmdSig -> ()
 2176 seqDmdSig (DmdSig ty) = seqDmdType ty
 2177 
 2178 {-
 2179 ************************************************************************
 2180 *                                                                      *
 2181                      Outputable and Binary instances
 2182 *                                                                      *
 2183 ************************************************************************
 2184 -}
 2185 
 2186 -- Just for debugging purposes.
 2187 instance Show Card where
 2188   show C_00 = "C_00"
 2189   show C_01 = "C_01"
 2190   show C_0N = "C_0N"
 2191   show C_10 = "C_10"
 2192   show C_11 = "C_11"
 2193   show C_1N = "C_1N"
 2194 
 2195 {- Note [Demand notation]
 2196 ~~~~~~~~~~~~~~~~~~~~~~~~~
 2197 This Note should be kept up to date with the documentation of `-fstrictness`
 2198 in the user's guide.
 2199 
 2200 For pretty-printing demands, we use quite a compact notation with some
 2201 abbreviations. Here's the BNF:
 2202 
 2203   card ::= B                        {}
 2204         |  A                        {0}
 2205         |  M                        {0,1}
 2206         |  L                        {0,1,n}
 2207         |  1                        {1}
 2208         |  S                        {1,n}
 2209 
 2210   box  ::= !                        Unboxed
 2211         |  <empty>                  Boxed
 2212 
 2213   d    ::= card sd                  The :* constructor, just juxtaposition
 2214         |  card                     abbreviation: Same as "card card"
 2215 
 2216   sd   ::= box card                 @Poly box card@
 2217         |  box P(d,d,..)            @Prod box [d1,d2,..]@
 2218         |  Ccard(sd)                @Call card sd@
 2219 
 2220 So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',
 2221 but it's always clear from context which "overload" is meant. It's like
 2222 return-type inference of e.g. 'read'.
 2223 
 2224 Examples are in the haddock for 'Demand'.
 2225 
 2226 This is the syntax for demand signatures:
 2227 
 2228   div ::= <empty>      topDiv
 2229        |  x            exnDiv
 2230        |  b            botDiv
 2231 
 2232   sig ::= {x->dx,y->dy,z->dz...}<d1><d2><d3>...<dn>div
 2233                   ^              ^   ^   ^      ^   ^
 2234                   |              |   |   |      |   |
 2235                   |              \---+---+------/   |
 2236                   |                  |              |
 2237              demand on free        demand on      divergence
 2238                variables           arguments      information
 2239            (omitted if empty)                     (omitted if
 2240                                                 no information)
 2241 
 2242 
 2243 -}
 2244 
 2245 -- | See Note [Demand notation]
 2246 -- Current syntax was discussed in #19016.
 2247 instance Outputable Card where
 2248   ppr C_00 = char 'A' -- "Absent"
 2249   ppr C_01 = char 'M' -- "Maybe"
 2250   ppr C_0N = char 'L' -- "Lazy"
 2251   ppr C_11 = char '1' -- "exactly 1"
 2252   ppr C_1N = char 'S' -- "Strict"
 2253   ppr C_10 = char 'B' -- "Bottom"
 2254 
 2255 -- | See Note [Demand notation]
 2256 instance Outputable Demand where
 2257   ppr AbsDmd                    = char 'A'
 2258   ppr BotDmd                    = char 'B'
 2259   ppr (C_0N :* Poly Boxed C_0N) = char 'L' -- Print LL as just L
 2260   ppr (C_1N :* Poly Boxed C_1N) = char 'S' -- Dito SS
 2261   ppr (n :* sd)                 = ppr n <> ppr sd
 2262 
 2263 -- | See Note [Demand notation]
 2264 instance Outputable SubDemand where
 2265   ppr (Poly b sd) = pp_boxity b <> ppr sd
 2266   ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd)
 2267   ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds)
 2268     where
 2269       fields []     = empty
 2270       fields [x]    = ppr x
 2271       fields (x:xs) = ppr x <> char ',' <> fields xs
 2272 
 2273 pp_boxity :: Boxity -> SDoc
 2274 pp_boxity Unboxed = char '!'
 2275 pp_boxity _       = empty
 2276 
 2277 instance Outputable Divergence where
 2278   ppr Diverges = char 'b' -- for (b)ottom
 2279   ppr ExnOrDiv = char 'x' -- for e(x)ception
 2280   ppr Dunno    = empty
 2281 
 2282 instance Outputable DmdType where
 2283   ppr (DmdType fv ds res)
 2284     = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,
 2285             if null fv_elts then empty
 2286             else braces (fsep (map pp_elt fv_elts))]
 2287     where
 2288       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
 2289       fv_elts = nonDetUFMToList fv
 2290         -- It's OK to use nonDetUFMToList here because we only do it for
 2291         -- pretty printing
 2292 
 2293 instance Outputable DmdSig where
 2294    ppr (DmdSig ty) = ppr ty
 2295 
 2296 instance Outputable TypeShape where
 2297   ppr TsUnk        = text "TsUnk"
 2298   ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
 2299   ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
 2300 
 2301 instance Binary Card where
 2302   put_ bh C_00 = putByte bh 0
 2303   put_ bh C_01 = putByte bh 1
 2304   put_ bh C_0N = putByte bh 2
 2305   put_ bh C_11 = putByte bh 3
 2306   put_ bh C_1N = putByte bh 4
 2307   put_ bh C_10 = putByte bh 5
 2308   get bh = do
 2309     h <- getByte bh
 2310     case h of
 2311       0 -> return C_00
 2312       1 -> return C_01
 2313       2 -> return C_0N
 2314       3 -> return C_11
 2315       4 -> return C_1N
 2316       5 -> return C_10
 2317       _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int))
 2318 
 2319 instance Binary Demand where
 2320   put_ bh (n :* sd) = put_ bh n *> case n of
 2321     C_00 -> return ()
 2322     C_10 -> return ()
 2323     _    -> put_ bh sd
 2324   get bh = get bh >>= \n -> case n of
 2325     C_00 -> return AbsDmd
 2326     C_10 -> return BotDmd
 2327     _    -> (n :*) <$> get bh
 2328 
 2329 instance Binary SubDemand where
 2330   put_ bh (Poly b sd) = putByte bh 0 *> put_ bh b *> put_ bh sd
 2331   put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd
 2332   put_ bh (Prod b ds) = putByte bh 2 *> put_ bh b *> put_ bh ds
 2333   get bh = do
 2334     h <- getByte bh
 2335     case h of
 2336       0 -> Poly <$> get bh <*> get bh
 2337       1 -> mkCall <$> get bh <*> get bh
 2338       2 -> Prod <$> get bh <*> get bh
 2339       _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))
 2340 
 2341 instance Binary DmdSig where
 2342   put_ bh (DmdSig aa) = put_ bh aa
 2343   get bh = DmdSig <$> get bh
 2344 
 2345 instance Binary DmdType where
 2346   -- Ignore DmdEnv when spitting out the DmdType
 2347   put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr
 2348   get bh = DmdType emptyDmdEnv <$> get bh <*> get bh
 2349 
 2350 instance Binary Divergence where
 2351   put_ bh Dunno    = putByte bh 0
 2352   put_ bh ExnOrDiv = putByte bh 1
 2353   put_ bh Diverges = putByte bh 2
 2354   get bh = do
 2355     h <- getByte bh
 2356     case h of
 2357       0 -> return Dunno
 2358       1 -> return ExnOrDiv
 2359       2 -> return Diverges
 2360       _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))