Demand.hs 74.2 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
\section[Demand]{@Demand@: A decoupled implementation of a demand domain}
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
9 10

module Demand (
Austin Seipp's avatar
Austin Seipp committed
11
        StrDmd, UseDmd(..), Count(..),
12
        countOnce, countMany,   -- cardinality
13

14
        Demand, CleanDemand, getStrDmd, getUseDmd,
15
        mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
16
        toCleanDmd,
17
        absDmd, topDmd, botDmd, seqDmd,
18 19
        lubDmd, bothDmd,
        lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,
20 21
        catchArgDmd,
        isTopDmd, isAbsDmd, isSeqDmd,
22
        peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
23
        addCaseBndrDmd,
24

25
        DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
26
        nopDmdType, botDmdType, mkDmdType,
27
        addDemand, removeDmdTyArgs,
28
        BothDmdArg, mkBothDmdArg, toBothDmdArg,
29 30

        DmdEnv, emptyDmdEnv,
31
        peelFV, findIdDemand,
32

33
        DmdResult, CPRResult,
Joachim Breitner's avatar
Joachim Breitner committed
34
        isBotRes, isTopRes,
35 36
        topRes, botRes, exnRes, cprProdRes,
        vanillaCprProdRes, cprSumRes,
Austin Seipp's avatar
Austin Seipp committed
37
        appIsBottom, isBottomingSig, pprIfaceStrictSig,
Joachim Breitner's avatar
Joachim Breitner committed
38
        trimCPRInfo, returnsCPR_maybe,
39
        StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
Joachim Breitner's avatar
Joachim Breitner committed
40
        isTopSig, splitStrictSig, increaseStrictSigArity,
41

Austin Seipp's avatar
Austin Seipp committed
42
        seqDemand, seqDemandList, seqDmdType, seqStrictSig,
43

Austin Seipp's avatar
Austin Seipp committed
44
        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,
45
        splitDmdTy, splitFVs,
46
        deferAfterIO,
47
        postProcessUnsat, postProcessDmdType,
48

49
        splitProdDmd_maybe, peelCallDmd, mkCallDmd,
50 51
        dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
        argOneShots, argsOneShots,
52
        trimToType, TypeShape(..),
53

54
        useCount, isUsedOnce, reuseEnv,
55
        killUsageDemand, killUsageSig, zapUsageDemand,
56
        strictifyDictDmd
57

sof's avatar
sof committed
58 59
     ) where

60 61
#include "HsVersions.h"

62
import DynFlags
63
import Outputable
64
import Var ( Var )
65 66
import VarEnv
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
67
import Util
68 69
import BasicTypes
import Binary
Joachim Breitner's avatar
Joachim Breitner committed
70
import Maybes           ( orElse )
71

72
import Type            ( Type, isUnliftedType )
73 74
import TyCon           ( isNewTyCon, isClassTyCon )
import DataCon         ( splitDataProductType_maybe )
75

Austin Seipp's avatar
Austin Seipp committed
76 77 78
{-
************************************************************************
*                                                                      *
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
        Joint domain for Strictness and Absence
*                                                                      *
************************************************************************
-}

data JointDmd s u = JD { sd :: s, ud :: u }
  deriving ( Eq, Show )

getStrDmd :: JointDmd s u -> s
getStrDmd = sd

getUseDmd :: JointDmd s u -> u
getUseDmd = ud

-- Pretty-printing
instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where
  ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u)

-- Well-formedness preserving constructors for the joint domain
mkJointDmd :: s -> u -> JointDmd s u
mkJointDmd s u = JD { sd = s, ud = u }

mkJointDmds :: [s] -> [u] -> [JointDmd s u]
mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as


{-
************************************************************************
*                                                                      *
            Strictness domain
Austin Seipp's avatar
Austin Seipp committed
109 110
*                                                                      *
************************************************************************
111

112 113
        Lazy
         |
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
  ExnStr x -
           |
        HeadStr
        /     \
    SCall      SProd
        \      /
        HyperStr

Note [Exceptions and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Exceptions need rather careful treatment, especially because of 'catch'.
See Trac #10712.

There are two main pieces.

* The Termination type includes ThrowsExn, meaning "under the given
  demand this expression either diverges or throws an exception".

  This is relatively uncontroversial. The primops raise# and
  raiseIO# both return ThrowsExn; nothing else does.

* An ArgStr has an ExnStr flag to say how to process the Termination
  result of the argument.  If the ExnStr flag is ExnStr, we squash
  ThrowsExn to topRes.  (This is done in postProcessDmdResult.)

Here is the kay example

    catch# (\s -> throwIO exn s) blah

We analyse the argument (\s -> raiseIO# exn s) with demand
    Str ExnStr (SCall HeadStr)
i.e. with the ExnStr flag set.
  - First we analyse the argument with the "clean-demand" (SCall
    HeadStr), getting a DmdResult of ThrowsExn from the saturated
    application of raiseIO#.
  - Then we apply the post-processing for the shell, squashing the
    ThrowsExn to topRes.

This also applies uniformly to free variables.  Consider

    let r = \st -> raiseIO# blah st
    in catch# (\s -> ...(r s')..) handler st

If we give the first argument of catch a strict signature, we'll get
a demand 'C(S)' for 'r'; that is, 'r' is definitely called with one
argument, which indeed it is.  But when we post-process the free-var
demands on catch#'s argument (in postProcessDmdEnv), we'll give 'r'
a demand of (Str ExnStr (SCall HeadStr)); and if we feed that into r's
RHS (which would be reasonable) we'll squash the exception just as if
we'd inlined 'r'.
Austin Seipp's avatar
Austin Seipp committed
164
-}
165

166 167
-- Vanilla strictness domain
data StrDmd
Austin Seipp's avatar
Austin Seipp committed
168
  = HyperStr             -- Hyper-strict
169
                         -- Bottom of the lattice
170
                         -- Note [HyperStr and Use demands]
171 172 173 174

  | SCall StrDmd         -- Call demand
                         -- Used only for values of function type

175
  | SProd [ArgStr]     -- Product
176 177
                         -- Used only for values of product type
                         -- Invariant: not all components are HyperStr (use HyperStr)
178
                         --            not all components are Lazy     (use HeadStr)
179

180
  | HeadStr              -- Head-Strict
181 182 183
                         -- A polymorphic demand: used for values of all types,
                         --                       including a type variable

184 185
  deriving ( Eq, Show )

186 187 188 189 190
type ArgStr = Str StrDmd

data Str s = Lazy         -- Lazy
                          -- Top of the lattice
           | Str ExnStr s
191 192
  deriving ( Eq, Show )

193 194 195 196 197 198 199
data ExnStr  -- See Note [Exceptions and strictness]
  = VanStr   -- "Vanilla" case, ordinary strictness

  | ExnStr   -- (Str ExnStr d) means be strict like 'd' but then degrade
             --                the Termination info ThrowsExn to Dunno
  deriving( Eq, Show )

200
-- Well-formedness preserving constructors for the Strictness domain
201 202
strBot, strTop :: ArgStr
strBot = Str VanStr HyperStr
203 204 205 206 207 208
strTop = Lazy

mkSCall :: StrDmd -> StrDmd
mkSCall HyperStr = HyperStr
mkSCall s        = SCall s

209
mkSProd :: [ArgStr] -> StrDmd
210 211 212 213 214
mkSProd sx
  | any isHyperStr sx = HyperStr
  | all isLazy     sx = HeadStr
  | otherwise         = SProd sx

215 216 217
isLazy :: ArgStr -> Bool
isLazy Lazy     = True
isLazy (Str {}) = False
218

219 220 221
isHyperStr :: ArgStr -> Bool
isHyperStr (Str _ HyperStr) = True
isHyperStr _                = False
222 223 224 225 226

-- Pretty-printing
instance Outputable StrDmd where
  ppr HyperStr      = char 'B'
  ppr (SCall s)     = char 'C' <> parens (ppr s)
227
  ppr HeadStr       = char 'S'
228 229
  ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))

230 231 232
instance Outputable ArgStr where
  ppr (Str x s)     = (case x of VanStr -> empty; ExnStr -> char 'x')
                      <> ppr s
233 234
  ppr Lazy          = char 'L'

235 236 237 238 239 240 241 242
lubArgStr :: ArgStr -> ArgStr -> ArgStr
lubArgStr Lazy        _           = Lazy
lubArgStr _           Lazy        = Lazy
lubArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `lubExnStr` x2) (s1 `lubStr` s2)

lubExnStr :: ExnStr -> ExnStr -> ExnStr
lubExnStr VanStr VanStr = VanStr
lubExnStr _      _      = ExnStr   -- ExnStr is lazier
243

244 245 246
lubStr :: StrDmd -> StrDmd -> StrDmd
lubStr HyperStr s              = s
lubStr (SCall s1) HyperStr     = SCall s1
247
lubStr (SCall _)  HeadStr      = HeadStr
248
lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)
249 250 251
lubStr (SCall _)  (SProd _)    = HeadStr
lubStr (SProd sx) HyperStr     = SProd sx
lubStr (SProd _)  HeadStr      = HeadStr
252
lubStr (SProd s1) (SProd s2)
253
    | length s1 == length s2   = mkSProd (zipWith lubArgStr s1 s2)
254 255 256 257
    | otherwise                = HeadStr
lubStr (SProd _) (SCall _)     = HeadStr
lubStr HeadStr   _             = HeadStr

258 259 260 261 262 263 264 265
bothArgStr :: ArgStr -> ArgStr -> ArgStr
bothArgStr Lazy        s           = s
bothArgStr s           Lazy        = s
bothArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `bothExnStr` x2) (s1 `bothStr` s2)

bothExnStr :: ExnStr -> ExnStr -> ExnStr
bothExnStr ExnStr ExnStr = ExnStr
bothExnStr _      _      = VanStr
266 267 268

bothStr :: StrDmd -> StrDmd -> StrDmd
bothStr HyperStr _             = HyperStr
269
bothStr HeadStr s              = s
270
bothStr (SCall _)  HyperStr    = HyperStr
271
bothStr (SCall s1) HeadStr     = SCall s1
272 273 274 275
bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)
bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird

bothStr (SProd _)  HyperStr    = HyperStr
276
bothStr (SProd s1) HeadStr     = SProd s1
Austin Seipp's avatar
Austin Seipp committed
277
bothStr (SProd s1) (SProd s2)
278
    | length s1 == length s2   = mkSProd (zipWith bothArgStr s1 s2)
279 280 281
    | otherwise                = HyperStr  -- Weird
bothStr (SProd _) (SCall _)    = HyperStr

282 283 284
-- utility functions to deal with memory leaks
seqStrDmd :: StrDmd -> ()
seqStrDmd (SProd ds)   = seqStrDmdList ds
Austin Seipp's avatar
Austin Seipp committed
285
seqStrDmd (SCall s)     = s `seq` ()
286 287
seqStrDmd _            = ()

288
seqStrDmdList :: [ArgStr] -> ()
289
seqStrDmdList [] = ()
290
seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds
291

292 293 294
seqArgStr :: ArgStr -> ()
seqArgStr Lazy      = ()
seqArgStr (Str x s) = x `seq` seqStrDmd s
295 296

-- Splitting polymorphic demands
297 298 299
splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]
splitArgStrProdDmd n Lazy      = Just (replicate n Lazy)
splitArgStrProdDmd n (Str _ s) = splitStrProdDmd n s
300

301
splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]
302 303 304 305 306 307
splitStrProdDmd n HyperStr   = Just (replicate n strBot)
splitStrProdDmd n HeadStr    = Just (replicate n strTop)
splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) Just ds
splitStrProdDmd _ (SCall {}) = Nothing
      -- This can happen when the programmer uses unsafeCoerce,
      -- and we don't then want to crash the compiler (Trac #9208)
308

Austin Seipp's avatar
Austin Seipp committed
309 310 311
{-
************************************************************************
*                                                                      *
312
            Absence domain
Austin Seipp's avatar
Austin Seipp committed
313 314
*                                                                      *
************************************************************************
315

316 317 318 319 320 321 322 323 324
         Used
         /   \
     UCall   UProd
         \   /
         UHead
          |
  Count x -
        |
       Abs
Austin Seipp's avatar
Austin Seipp committed
325
-}
326

327 328 329
-- Domain for genuine usage
data UseDmd
  = UCall Count UseDmd   -- Call demand for absence
330 331
                         -- Used only for values of function type

332
  | UProd [ArgUse]     -- Product
333 334 335 336 337
                         -- Used only for values of product type
                         -- See Note [Don't optimise UProd(Used) to Used]
                         -- [Invariant] Not all components are Abs
                         --             (in that case, use UHead)

Austin Seipp's avatar
Austin Seipp committed
338
  | UHead                -- May be used; but its sub-components are
339 340 341 342 343 344 345
                         -- definitely *not* used.  Roughly U(AAA)
                         -- Eg the usage of x in x `seq` e
                         -- A polymorphic demand: used for values of all types,
                         --                       including a type variable
                         -- Since (UCall _ Abs) is ill-typed, UHead doesn't
                         -- make sense for lambdas

346 347 348 349
  | Used                 -- May be used; and its sub-components may be used
                         -- Top of the lattice
  deriving ( Eq, Show )

350
-- Extended usage demand for absence and counting
351 352 353 354 355
type ArgUse = Use UseDmd

data Use u
  = Abs             -- Definitely unused
                    -- Bottom of the lattice
356

357
  | Use Count u     -- May be used with some cardinality
358 359 360 361
  deriving ( Eq, Show )

-- Abstract counting of usages
data Count = One | Many
Austin Seipp's avatar
Austin Seipp committed
362
  deriving ( Eq, Show )
363 364

-- Pretty-printing
365
instance Outputable ArgUse where
366
  ppr Abs           = char 'A'
Austin Seipp's avatar
Austin Seipp committed
367
  ppr (Use Many a)   = ppr a
368 369 370 371 372 373 374 375 376 377 378
  ppr (Use One  a)   = char '1' <> char '*' <> ppr a

instance Outputable UseDmd where
  ppr Used           = char 'U'
  ppr (UCall c a)    = char 'C' <> ppr c <> parens (ppr a)
  ppr UHead          = char 'H'
  ppr (UProd as)     = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))

instance Outputable Count where
  ppr One  = char '1'
  ppr Many = text ""
379 380

-- Well-formedness preserving constructors for the Absence domain
381 382 383 384
countOnce, countMany :: Count
countOnce = One
countMany = Many

385
useBot, useTop :: ArgUse
386 387 388 389
useBot     = Abs
useTop     = Use Many Used

mkUCall :: Count -> UseDmd -> UseDmd
Austin Seipp's avatar
Austin Seipp committed
390
--mkUCall c Used = Used c
391 392
mkUCall c a  = UCall c a

393
mkUProd :: [ArgUse] -> UseDmd
Austin Seipp's avatar
Austin Seipp committed
394
mkUProd ux
395 396 397
  | all (== Abs) ux    = UHead
  | otherwise          = UProd ux

398 399 400
lubCount :: Count -> Count -> Count
lubCount _ Many = Many
lubCount Many _ = Many
Austin Seipp's avatar
Austin Seipp committed
401
lubCount x _    = x
402

403 404 405 406
lubArgUse :: ArgUse -> ArgUse -> ArgUse
lubArgUse Abs x                   = x
lubArgUse x Abs                   = x
lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2)
407 408 409 410 411 412

lubUse :: UseDmd -> UseDmd -> UseDmd
lubUse UHead       u               = u
lubUse (UCall c u) UHead           = UCall c u
lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)
lubUse (UCall _ _) _               = Used
Austin Seipp's avatar
Austin Seipp committed
413
lubUse (UProd ux) UHead            = UProd ux
414
lubUse (UProd ux1) (UProd ux2)
415
     | length ux1 == length ux2    = UProd $ zipWith lubArgUse ux1 ux2
416 417 418
     | otherwise                   = Used
lubUse (UProd {}) (UCall {})       = Used
-- lubUse (UProd {}) Used             = Used
419 420
lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)
lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)
421 422 423 424
lubUse Used _                      = Used  -- Note [Used should win]

-- `both` is different from `lub` in its treatment of counting; if
-- `both` is computed for two used, the result always has
Austin Seipp's avatar
Austin Seipp committed
425
--  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).
426 427
--  Also,  x `bothUse` x /= x (for anything but Abs).

428 429 430 431
bothArgUse :: ArgUse -> ArgUse -> ArgUse
bothArgUse Abs x                   = x
bothArgUse x Abs                   = x
bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)
432 433 434 435 436 437


bothUse :: UseDmd -> UseDmd -> UseDmd
bothUse UHead       u               = u
bothUse (UCall c u) UHead           = UCall c u

Austin Seipp's avatar
Austin Seipp committed
438
-- Exciting special treatment of inner demand for call demands:
439 440 441 442
--    use `lubUse` instead of `bothUse`!
bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)

bothUse (UCall {}) _                = Used
Austin Seipp's avatar
Austin Seipp committed
443
bothUse (UProd ux) UHead            = UProd ux
444
bothUse (UProd ux1) (UProd ux2)
445
      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2
446 447 448
      | otherwise                   = Used
bothUse (UProd {}) (UCall {})       = Used
-- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
449 450
bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)
bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)
451 452 453 454 455
bothUse Used _                      = Used  -- Note [Used should win]

peelUseCall :: UseDmd -> Maybe (Count, UseDmd)
peelUseCall (UCall c u)   = Just (c,u)
peelUseCall _             = Nothing
456

457 458 459 460
addCaseBndrDmd :: Demand    -- On the case binder
               -> [Demand]  -- On the components of the constructor
               -> [Demand]  -- Final demands for the components of the constructor
-- See Note [Demand on case-alternative binders]
461
addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds
462 463 464 465
  = case mu of
     Abs     -> alt_dmds
     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
             where
466
                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call
467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492
                Just us = splitUseProdDmd      arity u   -- Ditto
  where
    arity = length alt_dmds

{- Note [Demand on case-alternative binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The demand on a binder in a case alternative comes
  (a) From the demand on the binder itself
  (b) From the demand on the case binder
Forgetting (b) led directly to Trac #10148.

Example. Source code:
  f x@(p,_) = if p then foo x else True

  foo (p,True) = True
  foo (p,q)    = foo (q,p)

After strictness analysis:
  f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->
      case x_an1
      of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]
      { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->
      case p_an2 of _ {
        False -> GHC.Types.True;
        True -> foo wild_X7 }

493
It's true that ds_dnz is *itself* absent, but the use of wild_X7 means
494 495 496 497 498 499
that it is very much alive and demanded.  See Trac #10148 for how the
consequences play out.

This is needed even for non-product types, in case the case-binder
is used but the components of the case alternative are not.

500 501 502 503 504 505 506 507
Note [Don't optimise UProd(Used) to Used]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These two UseDmds:
   UProd [Used, Used]   and    Used
are semantically equivalent, but we do not turn the former into
the latter, for a regrettable-subtle reason.  Suppose we did.
then
  f (x,y) = (y,x)
Austin Seipp's avatar
Austin Seipp committed
508
would get
509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527
  StrDmd = Str  = SProd [Lazy, Lazy]
  UseDmd = Used = UProd [Used, Used]
But with the joint demand of <Str, Used> doesn't convey any clue
that there is a product involved, and so the worthSplittingFun
will not fire.  (We'd need to use the type as well to make it fire.)
Moreover, consider
  g h p@(_,_) = h p
This too would get <Str, Used>, but this time there really isn't any
point in w/w since the components of the pair are not used at all.

So the solution is: don't aggressively collapse UProd [Used,Used] to
Used; intead leave it as-is. In effect we are using the UseDmd to do a
little bit of boxity analysis.  Not very nice.

Note [Used should win]
~~~~~~~~~~~~~~~~~~~~~~
Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.
Why?  Because Used carries the implication the whole thing is used,
box and all, so we don't want to w/w it.  If we use it both boxed and
Austin Seipp's avatar
Austin Seipp committed
528
unboxed, then we are definitely using the box, and so we are quite
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545
likely to pay a reboxing cost.  So we make Used win here.

Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer

Baseline: (A) Not making Used win (UProd wins)
Compare with: (B) making Used win for lub and both

            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%
            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%
 Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%

Baseline: (B) Making Used win for both lub and both
Compare with: (C) making Used win for both, but UProd win for lub

            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%
            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%
 Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%
Austin Seipp's avatar
Austin Seipp committed
546
-}
547

548 549
-- If a demand is used multiple times (i.e. reused), than any use-once
-- mentioned there, that is not protected by a UCall, can happen many times.
550
markReusedDmd :: ArgUse -> ArgUse
551 552
markReusedDmd Abs         = Abs
markReusedDmd (Use _ a)   = Use Many (markReused a)
553

554 555 556 557
markReused :: UseDmd -> UseDmd
markReused (UCall _ u)      = UCall Many u   -- No need to recurse here
markReused (UProd ux)       = UProd (map markReusedDmd ux)
markReused u                = u
558

559
isUsedMU :: ArgUse -> Bool
560
-- True <=> markReusedDmd d = d
561 562 563 564 565
isUsedMU Abs          = True
isUsedMU (Use One _)  = False
isUsedMU (Use Many u) = isUsedU u

isUsedU :: UseDmd -> Bool
566
-- True <=> markReused d = d
567 568 569 570 571 572 573 574
isUsedU Used           = True
isUsedU UHead          = True
isUsedU (UProd us)     = all isUsedMU us
isUsedU (UCall One _)  = False
isUsedU (UCall Many _) = True  -- No need to recurse

-- Squashing usage demand demands
seqUseDmd :: UseDmd -> ()
575
seqUseDmd (UProd ds)   = seqArgUseList ds
576 577 578
seqUseDmd (UCall c d)  = c `seq` seqUseDmd d
seqUseDmd _            = ()

579 580 581
seqArgUseList :: [ArgUse] -> ()
seqArgUseList []     = ()
seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds
582

583 584 585
seqArgUse :: ArgUse -> ()
seqArgUse (Use c u)  = c `seq` seqUseDmd u
seqArgUse _          = ()
586 587

-- Splitting polymorphic Maybe-Used demands
588
splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]
589 590
splitUseProdDmd n Used        = Just (replicate n useTop)
splitUseProdDmd n UHead       = Just (replicate n Abs)
Austin Seipp's avatar
Austin Seipp committed
591
splitUseProdDmd n (UProd ds)  = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds )
592 593 594 595
                                Just ds
splitUseProdDmd _ (UCall _ _) = Nothing
      -- This can happen when the programmer uses unsafeCoerce,
      -- and we don't then want to crash the compiler (Trac #9208)
596

597 598 599 600
useCount :: Use u -> Count
useCount Abs         = One
useCount (Use One _) = One
useCount _           = Many
601 602


Austin Seipp's avatar
Austin Seipp committed
603 604 605
{-
************************************************************************
*                                                                      *
606
         Clean demand for Strictness and Usage
Austin Seipp's avatar
Austin Seipp committed
607 608
*                                                                      *
************************************************************************
609

610 611
This domain differst from JointDemand in the sence that pure absence
is taken away, i.e., we deal *only* with non-absent demands.
612

613 614
Note [Strict demands]
~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
615
isStrictDmd returns true only of demands that are
616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631
   both strict
   and  used
In particular, it is False for <HyperStr, Abs>, which can and does
arise in, say (Trac #7319)
   f x = raise# <some exception>
Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> .
Now the w/w generates
   fx = let x <HyperStr,Abs> = absentError "unused"
        in raise <some exception>
At this point we really don't want to convert to
   fx = case absentError "unused" of x -> raise <some exception>
Since the program is going to diverge, this swaps one error for another,
but it's really a bad idea to *ever* evaluate an absent argument.
In Trac #7319 we get
   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]

632 633 634 635 636 637 638 639 640 641
Note [Dealing with call demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call demands are constructed and deconstructed coherently for
strictness and absence. For instance, the strictness signature for the
following function

f :: (Int -> (Int, Int)) -> (Int, Bool)
f g = (snd (g 3), True)

should be: <L,C(U(AU))>m
Austin Seipp's avatar
Austin Seipp committed
642
-}
643

644 645
type CleanDemand = JointDmd StrDmd UseDmd
     -- A demand that is at least head-strict
646 647

bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
648 649
bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})
  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }
650 651

mkHeadStrict :: CleanDemand -> CleanDemand
652
mkHeadStrict cd = cd { sd = HeadStr }
653

654 655 656
mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand
mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a }
mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a }
657

658
evalDmd :: Demand
659
-- Evaluated strictly, and used arbitrarily deeply
660
evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }
661

662
mkProdDmd :: [Demand] -> CleanDemand
Austin Seipp's avatar
Austin Seipp committed
663
mkProdDmd dx
664 665
  = JD { sd = mkSProd $ map getStrDmd dx
       , ud = mkUProd $ map getUseDmd dx }
666 667

mkCallDmd :: CleanDemand -> CleanDemand
668 669
mkCallDmd (JD {sd = d, ud = u})
  = JD { sd = mkSCall d, ud = mkUCall One u }
670 671

cleanEvalDmd :: CleanDemand
672
cleanEvalDmd = JD { sd = HeadStr, ud = Used }
673 674

cleanEvalProdDmd :: Arity -> CleanDemand
675
cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }
676

677

678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782
{-
************************************************************************
*                                                                      *
           Demand: combining stricness and usage
*                                                                      *
************************************************************************
-}

type Demand = JointDmd ArgStr ArgUse

lubDmd :: Demand -> Demand -> Demand
lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
 = JD { sd = s1 `lubArgStr` s2
      , ud = a1 `lubArgUse` a2 }

bothDmd :: Demand -> Demand -> Demand
bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
 = JD { sd = s1 `bothArgStr` s2
      , ud = a1 `bothArgUse` a2 }

lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand

strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)
                     , ud = Use Many (UCall One Used) }

-- First argument of catch#:
--    uses its arg once, applies it once
--    and catches exceptions (the ExnStr) part
catchArgDmd = JD { sd = Str ExnStr (SCall HeadStr)
                 , ud = Use One (UCall One Used) }

lazyApply1Dmd = JD { sd = Lazy
                   , ud = Use One (UCall One Used) }

-- Second argument of catch#:
--    uses its arg at most once, applies it once
--    but is lazy (might not be called at all)
lazyApply2Dmd = JD { sd = Lazy
                   , ud = Use One (UCall One (UCall One Used)) }

absDmd :: Demand
absDmd = JD { sd = Lazy, ud = Abs }

topDmd :: Demand
topDmd = JD { sd = Lazy, ud = useTop }

botDmd :: Demand
botDmd = JD { sd = strBot, ud = useBot }

seqDmd :: Demand
seqDmd = JD { sd = Str VanStr HeadStr, ud = Use One UHead }

oneifyDmd :: Demand -> Demand
oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }
oneifyDmd jd                            = jd

isTopDmd :: Demand -> Bool
-- Used to suppress pretty-printing of an uninformative demand
isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True
isTopDmd _                                    = False

isAbsDmd :: Demand -> Bool
isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr
isAbsDmd _               = False  -- for a bottom demand

isSeqDmd :: Demand -> Bool
isSeqDmd (JD {sd = Str VanStr HeadStr, ud = Use _ UHead}) = True
isSeqDmd _                                                = False

isUsedOnce :: Demand -> Bool
isUsedOnce (JD { ud = a }) = case useCount a of
                               One  -> True
                               Many -> False

-- More utility functions for strictness
seqDemand :: Demand -> ()
seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u

seqDemandList :: [Demand] -> ()
seqDemandList [] = ()
seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds

isStrictDmd :: Demand -> Bool
-- See Note [Strict demands]
isStrictDmd (JD {ud = Abs})  = False
isStrictDmd (JD {sd = Lazy}) = False
isStrictDmd _                = True

isWeakDmd :: Demand -> Bool
isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a

cleanUseDmd_maybe :: Demand -> Maybe UseDmd
cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u
cleanUseDmd_maybe _                     = Nothing

splitFVs :: Bool   -- Thunk
         -> DmdEnv -> (DmdEnv, DmdEnv)
splitFVs is_thunk rhs_fvs
  | is_thunk  = foldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
  | otherwise = partitionVarEnv isWeakDmd rhs_fvs
  where
    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)
      | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)
      | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })
                    , addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs }) )
783 784 785 786 787 788

data TypeShape = TsFun TypeShape
               | TsProd [TypeShape]
               | TsUnk

instance Outputable TypeShape where
789 790
  ppr TsUnk        = text "TsUnk"
  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
791 792
  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)

793
trimToType :: Demand -> TypeShape -> Demand
794
-- See Note [Trimming a demand to a type]
795
trimToType (JD { sd = ms, ud = mu }) ts
796 797
  = JD (go_ms ms ts) (go_mu mu ts)
  where
798 799 800
    go_ms :: ArgStr -> TypeShape -> ArgStr
    go_ms Lazy      _  = Lazy
    go_ms (Str x s) ts = Str x (go_s s ts)
801 802 803 804 805 806 807 808

    go_s :: StrDmd -> TypeShape -> StrDmd
    go_s HyperStr    _            = HyperStr
    go_s (SCall s)   (TsFun ts)   = SCall (go_s s ts)
    go_s (SProd mss) (TsProd tss)
      | equalLength mss tss       = SProd (zipWith go_ms mss tss)
    go_s _           _            = HeadStr

809
    go_mu :: ArgUse -> TypeShape -> ArgUse
810 811 812 813 814 815 816 817 818
    go_mu Abs _ = Abs
    go_mu (Use c u) ts = Use c (go_u u ts)

    go_u :: UseDmd -> TypeShape -> UseDmd
    go_u UHead       _          = UHead
    go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)
    go_u (UProd mus) (TsProd tss)
      | equalLength mus tss      = UProd (zipWith go_mu mus tss)
    go_u _           _           = Used
819

Austin Seipp's avatar
Austin Seipp committed
820
{-
821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841
Note [Trimming a demand to a type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:

  f :: a -> Bool
  f x = case ... of
          A g1 -> case (x |> g1) of (p,q) -> ...
          B    -> error "urk"

where A,B are the constructors of a GADT.  We'll get a U(U,U) demand
on x from the A branch, but that's a stupid demand for x itself, which
has type 'a'. Indeed we get ASSERTs going off (notably in
splitUseProdDmd, Trac #8569).

Bottom line: we really don't want to have a binder whose demand is more
deeply-nested than its type.  There are various ways to tackle this.
When processing (x |> g1), we could "trim" the incoming demand U(U,U)
to match x's type.  But I'm currently doing so just at the moment when
we pin a demand on a binder, in DmdAnal.findBndrDmd.


842 843 844 845 846 847
Note [Threshold demands]
~~~~~~~~~~~~~~~~~~~~~~~~
Threshold usage demand is generated to figure out if
cardinality-instrumented demands of a binding's free variables should
be unleashed. See also [Aggregated demand for cardinality].

848 849 850 851 852 853 854 855 856
Note [Replicating polymorphic demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some demands can be considered as polymorphic. Generally, it is
applicable to such beasts as tops, bottoms as well as Head-Used adn
Head-stricts demands. For instance,

S ~ S(L, ..., L)

Also, when top or bottom is occurred as a result demand, it in fact
Austin Seipp's avatar
Austin Seipp committed
857 858
can be expanded to saturate a callee's arity.
-}
859

860
splitProdDmd_maybe :: Demand -> Maybe [Demand]
861 862 863
-- Split a product into its components, iff there is any
-- useful information to be extracted thereby
-- The demand is not necessarily strict!
864
splitProdDmd_maybe (JD { sd = s, ud = u })
865
  = case (s,u) of
866 867 868 869 870
      (Str _ (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
                                  -> Just (mkJointDmds sx ux)
      (Str _ s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
                                  -> Just (mkJointDmds sx ux)
      (Lazy,    Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
871
      _ -> Nothing
872

Austin Seipp's avatar
Austin Seipp committed
873 874 875
{-
************************************************************************
*                                                                      *
876
                   Demand results
Austin Seipp's avatar
Austin Seipp committed
877 878
*                                                                      *
************************************************************************
879

880 881 882

DmdResult:     Dunno CPRResult
               /
883 884
           ThrowsExn
             /
885 886 887 888 889 890 891 892 893 894 895
        Diverges


CPRResult:         NoCPR
                   /    \
            RetProd    RetSum ConTag


Product contructors return (Dunno (RetProd rs))
In a fixpoint iteration, start from Diverges
We have lubs, but not glbs; but that is ok.
Austin Seipp's avatar
Austin Seipp committed
896
-}
897

898
------------------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
899
-- Constructed Product Result
900 901
------------------------------------------------------------------------

902 903 904 905 906
data Termination r
  = Diverges    -- Definitely diverges
  | ThrowsExn   -- Definitely throws an exception or diverges
  | Dunno r     -- Might diverge or converge
  deriving( Eq, Show )
907

908 909 910 911 912
type DmdResult = Termination CPRResult

data CPRResult = NoCPR          -- Top of the lattice
               | RetProd        -- Returns a constructor from a product type
               | RetSum ConTag  -- Returns a constructor from a data type
913 914
               deriving( Eq, Show )

915
lubCPR :: CPRResult -> CPRResult -> CPRResult
Austin Seipp's avatar
Austin Seipp committed
916
lubCPR (RetSum t1) (RetSum t2)
917
  | t1 == t2                       = RetSum t1
918 919
lubCPR RetProd     RetProd     = RetProd
lubCPR _ _                     = NoCPR
920 921 922

lubDmdResult :: DmdResult -> DmdResult -> DmdResult
lubDmdResult Diverges       r              = r
923 924
lubDmdResult ThrowsExn      Diverges       = ThrowsExn
lubDmdResult ThrowsExn      r              = r
925
lubDmdResult (Dunno c1)     Diverges       = Dunno c1
926
lubDmdResult (Dunno c1)     ThrowsExn      = Dunno c1
927
lubDmdResult (Dunno c1)     (Dunno c2)     = Dunno (c1 `lubCPR` c2)
928
-- This needs to commute with defaultDmd, i.e.
929
-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
930
-- (See Note [Default demand on free variables] for why)
931

932
bothDmdResult :: DmdResult -> Termination () -> DmdResult
933
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
934 935 936
bothDmdResult _ Diverges   = Diverges
bothDmdResult r ThrowsExn  = case r of { Diverges -> r; _ -> ThrowsExn }
bothDmdResult r (Dunno {}) = r
937
-- This needs to commute with defaultDmd, i.e.
938
-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
939
-- (See Note [Default demand on free variables] for why)
940

941
instance Outputable r => Outputable (Termination r) where
942
  ppr Diverges      = char 'b'
943
  ppr ThrowsExn     = char 'x'
944
  ppr (Dunno c)     = ppr c
945

946 947 948 949
instance Outputable CPRResult where
  ppr NoCPR        = empty
  ppr (RetSum n)   = char 'm' <> int n
  ppr RetProd      = char 'm'
950

951
seqDmdResult :: DmdResult -> ()
952 953 954
seqDmdResult Diverges  = ()
seqDmdResult ThrowsExn = ()
seqDmdResult (Dunno c) = seqCPRResult c
955

956 957 958 959
seqCPRResult :: CPRResult -> ()
seqCPRResult NoCPR        = ()
seqCPRResult (RetSum n)   = n `seq` ()
seqCPRResult RetProd      = ()
960

961 962 963 964

------------------------------------------------------------------------
-- Combined demand result                                             --
------------------------------------------------------------------------
965

966
-- [cprRes] lets us switch off CPR analysis
967
-- by making sure that everything uses TopRes
968
topRes, exnRes, botRes :: DmdResult
969
topRes = Dunno NoCPR
970
exnRes = ThrowsExn
971
botRes = Diverges
972

973
cprSumRes :: ConTag -> DmdResult
974
cprSumRes tag = Dunno $ RetSum tag
975

976
cprProdRes :: [DmdType] -> DmdResult
977
cprProdRes _arg_tys = Dunno $ RetProd
978

979
vanillaCprProdRes :: Arity -> DmdResult
980
vanillaCprProdRes _arity = Dunno $ RetProd
981

982
isTopRes :: DmdResult -> Bool
983 984
isTopRes (Dunno NoCPR) = True
isTopRes _             = False
985 986

isBotRes :: DmdResult -> Bool
987 988 989 990
-- True if the result diverges or throws an exception
isBotRes Diverges   = True
isBotRes ThrowsExn  = True
isBotRes (Dunno {}) = False
991 992 993 994 995

trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
trimCPRInfo trim_all trim_sums res
  = trimR res
  where
996 997
    trimR (Dunno c) = Dunno (trimC c)
    trimR res       = res
998 999 1000 1001 1002 1003

    trimC (RetSum n)   | trim_all || trim_sums = NoCPR
                       | otherwise             = RetSum n
    trimC RetProd      | trim_all  = NoCPR
                       | otherwise = RetProd
    trimC NoCPR = NoCPR
1004

1005
returnsCPR_maybe :: DmdResult -> Maybe ConTag
1006 1007
returnsCPR_maybe (Dunno c) = retCPR_maybe c
returnsCPR_maybe _         = Nothing
1008 1009 1010 1011 1012

retCPR_maybe :: CPRResult -> Maybe ConTag
retCPR_maybe (RetSum t)  = Just t
retCPR_maybe RetProd     = Just fIRST_TAG
retCPR_maybe NoCPR       = Nothing
1013

Gabor Greif's avatar
Gabor Greif committed
1014
-- See Notes [Default demand on free variables]