Demand.hs 76.5 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, RecordWildCards #-}
9 10

module Demand (
11
        StrDmd, UseDmd(..), Count,
12

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

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

        DmdEnv, emptyDmdEnv,
30
        peelFV, findIdDemand,
31

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

Austin Seipp's avatar
Austin Seipp committed
44
        seqDemand, seqDemandList, seqDmdType, seqStrictSig,
45

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

51
        splitProdDmd_maybe, peelCallDmd, mkCallDmd, mkWorkerDemand,
52
        dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
53
        argOneShots, argsOneShots, saturatedByOneShots,
54
        trimToType, TypeShape(..),
55

56
        useCount, isUsedOnce, reuseEnv,
57 58
        killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,
        zapUsedOnceDemand, zapUsedOnceSig,
59
        strictifyDictDmd
60

sof's avatar
sof committed
61 62
     ) where

63 64
#include "HsVersions.h"

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

75
import Type            ( Type, isUnliftedType )
76 77
import TyCon           ( isNewTyCon, isClassTyCon )
import DataCon         ( splitDataProductType_maybe )
78

Austin Seipp's avatar
Austin Seipp committed
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 109 110 111
        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
112 113
*                                                                      *
************************************************************************
114

115 116
        Lazy
         |
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 164 165 166
  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
167
-}
168

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

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

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

183
  | HeadStr              -- Head-Strict
184 185 186
                         -- A polymorphic demand: used for values of all types,
                         --                       including a type variable

187 188
  deriving ( Eq, Show )

189 190 191 192 193
type ArgStr = Str StrDmd

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

196 197 198 199 200 201 202
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 )

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

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

212
mkSProd :: [ArgStr] -> StrDmd
213 214 215 216 217
mkSProd sx
  | any isHyperStr sx = HyperStr
  | all isLazy     sx = HeadStr
  | otherwise         = SProd sx

218 219 220
isLazy :: ArgStr -> Bool
isLazy Lazy     = True
isLazy (Str {}) = False
221

222 223 224
isHyperStr :: ArgStr -> Bool
isHyperStr (Str _ HyperStr) = True
isHyperStr _                = False
225 226 227 228 229

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

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

238 239 240 241 242 243 244 245
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
246

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

261 262 263 264 265 266 267 268
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
269 270 271

bothStr :: StrDmd -> StrDmd -> StrDmd
bothStr HyperStr _             = HyperStr
272
bothStr HeadStr s              = s
273
bothStr (SCall _)  HyperStr    = HyperStr
274
bothStr (SCall s1) HeadStr     = SCall s1
275 276 277 278
bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)
bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird

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

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

291
seqStrDmdList :: [ArgStr] -> ()
292
seqStrDmdList [] = ()
293
seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds
294

295 296 297
seqArgStr :: ArgStr -> ()
seqArgStr Lazy      = ()
seqArgStr (Str x s) = x `seq` seqStrDmd s
298 299

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

304
splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]
305 306 307 308 309 310
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)
311

Austin Seipp's avatar
Austin Seipp committed
312 313 314
{-
************************************************************************
*                                                                      *
315
            Absence domain
Austin Seipp's avatar
Austin Seipp committed
316 317
*                                                                      *
************************************************************************
318

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

330 331 332
-- Domain for genuine usage
data UseDmd
  = UCall Count UseDmd   -- Call demand for absence
333 334
                         -- Used only for values of function type

335
  | UProd [ArgUse]     -- Product
336 337 338 339 340
                         -- 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
341
  | UHead                -- May be used; but its sub-components are
342 343 344 345 346 347 348
                         -- 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

349 350 351 352
  | Used                 -- May be used; and its sub-components may be used
                         -- Top of the lattice
  deriving ( Eq, Show )

353
-- Extended usage demand for absence and counting
354 355 356 357 358
type ArgUse = Use UseDmd

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

360
  | Use Count u     -- May be used with some cardinality
361 362 363 364
  deriving ( Eq, Show )

-- Abstract counting of usages
data Count = One | Many
Austin Seipp's avatar
Austin Seipp committed
365
  deriving ( Eq, Show )
366 367

-- Pretty-printing
368
instance Outputable ArgUse where
369
  ppr Abs           = char 'A'
Austin Seipp's avatar
Austin Seipp committed
370
  ppr (Use Many a)   = ppr a
371 372 373 374 375 376 377 378 379 380 381
  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 ""
382

383
useBot, useTop :: ArgUse
384 385 386 387
useBot     = Abs
useTop     = Use Many Used

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

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

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

401 402 403 404
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)
405 406 407 408 409 410

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
411
lubUse (UProd ux) UHead            = UProd ux
412
lubUse (UProd ux1) (UProd ux2)
413
     | length ux1 == length ux2    = UProd $ zipWith lubArgUse ux1 ux2
414 415 416
     | otherwise                   = Used
lubUse (UProd {}) (UCall {})       = Used
-- lubUse (UProd {}) Used             = Used
417 418
lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)
lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)
419 420 421 422
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
423
--  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).
424 425
--  Also,  x `bothUse` x /= x (for anything but Abs).

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


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

Austin Seipp's avatar
Austin Seipp committed
436
-- Exciting special treatment of inner demand for call demands:
437 438 439 440
--    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
441
bothUse (UProd ux) UHead            = UProd ux
442
bothUse (UProd ux1) (UProd ux2)
443
      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2
444 445 446
      | otherwise                   = Used
bothUse (UProd {}) (UCall {})       = Used
-- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
447 448
bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)
bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)
449 450 451 452 453
bothUse Used _                      = Used  -- Note [Used should win]

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

455 456 457 458
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]
459
addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds
460 461 462 463
  = case mu of
     Abs     -> alt_dmds
     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
             where
464
                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call
465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490
                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 }

491
It's true that ds_dnz is *itself* absent, but the use of wild_X7 means
492 493 494 495 496 497
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.

498 499 500 501 502 503 504 505
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
506
would get
507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
  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
526
unboxed, then we are definitely using the box, and so we are quite
527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543
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
544
-}
545

546 547
-- 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.
548
markReusedDmd :: ArgUse -> ArgUse
549 550
markReusedDmd Abs         = Abs
markReusedDmd (Use _ a)   = Use Many (markReused a)
551

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

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

isUsedU :: UseDmd -> Bool
564
-- True <=> markReused d = d
565 566 567 568 569 570 571 572
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 -> ()
573
seqUseDmd (UProd ds)   = seqArgUseList ds
574 575 576
seqUseDmd (UCall c d)  = c `seq` seqUseDmd d
seqUseDmd _            = ()

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

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

-- Splitting polymorphic Maybe-Used demands
586
splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]
587 588
splitUseProdDmd n Used        = Just (replicate n useTop)
splitUseProdDmd n UHead       = Just (replicate n Abs)
Austin Seipp's avatar
Austin Seipp committed
589
splitUseProdDmd n (UProd ds)  = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds )
590 591 592 593
                                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)
594

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


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

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

611 612
Note [Strict demands]
~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
613
isStrictDmd returns true only of demands that are
614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629
   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}]

630 631 632 633 634 635 636 637 638 639
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
640
-}
641

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

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

mkHeadStrict :: CleanDemand -> CleanDemand
650
mkHeadStrict cd = cd { sd = HeadStr }
651

652 653 654
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 }
655

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

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

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

669 670 671 672 673 674
-- See Note [Demand on the worker] in WorkWrap
mkWorkerDemand :: Int -> Demand
mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }
  where go 0 = Used
        go n = mkUCall One $ go (n-1)

675
cleanEvalDmd :: CleanDemand
676
cleanEvalDmd = JD { sd = HeadStr, ud = Used }
677 678

cleanEvalProdDmd :: Arity -> CleanDemand
679
cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }
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
{-
************************************************************************
*                                                                      *
           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
niteria's avatar
niteria committed
780 781 782 783
  | is_thunk  = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
                -- It's OK to use nonDetFoldUFM_Directly because we
                -- immediately forget the ordering by putting the elements
                -- in the envs again
784 785 786 787 788 789
  | 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 }) )
790 791 792 793 794 795

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

instance Outputable TypeShape where
796 797
  ppr TsUnk        = text "TsUnk"
  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
798 799
  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)

800
trimToType :: Demand -> TypeShape -> Demand
801
-- See Note [Trimming a demand to a type]
802
trimToType (JD { sd = ms, ud = mu }) ts
803 804
  = JD (go_ms ms ts) (go_mu mu ts)
  where
805 806 807
    go_ms :: ArgStr -> TypeShape -> ArgStr
    go_ms Lazy      _  = Lazy
    go_ms (Str x s) ts = Str x (go_s s ts)
808 809 810 811 812 813 814 815

    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

816
    go_mu :: ArgUse -> TypeShape -> ArgUse
817 818 819 820 821 822 823 824 825
    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
826

Austin Seipp's avatar
Austin Seipp committed
827
{-
828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848
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.


849 850 851 852 853 854
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].

855 856 857 858 859 860 861 862 863
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
864 865
can be expanded to saturate a callee's arity.
-}
866

867
splitProdDmd_maybe :: Demand -> Maybe [Demand]
868 869 870
-- Split a product into its components, iff there is any
-- useful information to be extracted thereby
-- The demand is not necessarily strict!
871
splitProdDmd_maybe (JD { sd = s, ud = u })
872
  = case (s,u) of
873 874 875 876 877
      (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)
878
      _ -> Nothing
879

Austin Seipp's avatar
Austin Seipp committed
880 881 882
{-
************************************************************************
*                                                                      *
883
                   Demand results
Austin Seipp's avatar
Austin Seipp committed
884 885
*                                                                      *
************************************************************************
886

887 888 889

DmdResult:     Dunno CPRResult
               /
890 891
           ThrowsExn
             /
892 893 894 895 896 897 898 899
        Diverges


CPRResult:         NoCPR
                   /    \
            RetProd    RetSum ConTag


Gabor Greif's avatar
Gabor Greif committed
900
Product constructors return (Dunno (RetProd rs))
901 902
In a fixpoint iteration, start from Diverges
We have lubs, but not glbs; but that is ok.
Austin Seipp's avatar
Austin Seipp committed
903
-}
904

905
------------------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
906
-- Constructed Product Result
907 908
------------------------------------------------------------------------

909 910 911 912 913
data Termination r
  = Diverges    -- Definitely diverges
  | ThrowsExn   -- Definitely throws an exception or diverges
  | Dunno r     -- Might diverge or converge
  deriving( Eq, Show )
914

915 916 917 918 919
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
920 921
               deriving( Eq, Show )

922
lubCPR :: CPRResult -> CPRResult -> CPRResult
Austin Seipp's avatar
Austin Seipp committed
923
lubCPR (RetSum t1) (RetSum t2)
924
  | t1 == t2                       = RetSum t1
925 926
lubCPR RetProd     RetProd     = RetProd
lubCPR _ _                     = NoCPR
927 928 929

lubDmdResult :: DmdResult -> DmdResult -> DmdResult
lubDmdResult Diverges       r              = r
930 931
lubDmdResult ThrowsExn      Diverges       = ThrowsExn
lubDmdResult ThrowsExn      r              = r
932
lubDmdResult (Dunno c1)     Diverges       = Dunno c1
933
lubDmdResult (Dunno c1)     ThrowsExn      = Dunno c1
934
lubDmdResult (Dunno c1)     (Dunno c2)     = Dunno (c1 `lubCPR` c2)
935
-- This needs to commute with defaultDmd, i.e.
936
-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
937
-- (See Note [Default demand on free variables] for why)
938

939
bothDmdResult :: DmdResult -> Termination () -> DmdResult
940
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
941 942 943
bothDmdResult _ Diverges   = Diverges
bothDmdResult r ThrowsExn  = case r of { Diverges -> r; _ -> ThrowsExn }
bothDmdResult r (Dunno {}) = r
944
-- This needs to commute with defaultDmd, i.e.
945
-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
946
-- (See Note [Default demand on free variables] for why)
947

948
instance Outputable r => Outputable (Termination r) where
949
  ppr Diverges      = char 'b'
950
  ppr ThrowsExn     = char 'x'
951
  ppr (Dunno c)     = ppr c
952

953 954 955 956
instance Outputable CPRResult where
  ppr NoCPR        = empty
  ppr (RetSum n)   = char 'm' <> int n
  ppr RetProd      = char 'm'
957

958
seqDmdResult :: DmdResult -> ()
959 960 961
seqDmdResult Diverges  = ()
seqDmdResult ThrowsExn = ()
seqDmdResult (Dunno c) = seqCPRResult c
962

963 964 965 966
seqCPRResult :: CPRResult -> ()
seqCPRResult NoCPR        = ()
seqCPRResult (RetSum n)   = n `seq` ()
seqCPRResult RetProd      = ()
967

968 969 970 971

------------------------------------------------------------------------
-- Combined demand result                                             --
------------------------------------------------------------------------
972

973
-- [cprRes] lets us switch off CPR analysis
974
-- by making sure that everything uses TopRes
975
topRes, exnRes, botRes :: DmdResult
976
topRes = Dunno NoCPR
977
exnRes = ThrowsExn
978
botRes = Diverges
979

980
cprSumRes :: ConTag -> DmdResult
981
cprSumRes tag = Dunno $ RetSum tag
982

983
cprProdRes :: [DmdType] -> DmdResult
984
cprProdRes _arg_tys = Dunno $ RetProd
985

986
vanillaCprProdRes :: Arity -> DmdResult
987
vanillaCprProdRes _arity = Dunno $ RetProd
988

989
isTopRes :: DmdResult -> Bool
990 991
isTopRes (Dunno NoCPR) = True
isTopRes _             = False
992 993

isBotRes :: DmdResult -> Bool
994 995 996 997
-- True if the result diverges or throws an exception
isBotRes Diverges   = True
isBotRes ThrowsExn  = True
isBotRes (Dunno {}) = False
998 999 1000 1001 1002

trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
trimCPRInfo trim_all trim_sums res
  = trimR res
  where
1003 1004
    trimR (Dunno c) = Dunno (trimC c)
    trimR res       = res
1005 1006 1007 1008 1009 1010

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

1012
returnsCPR_maybe :: DmdResult -> Maybe ConTag
1013 1014
returnsCPR_maybe (Dunno c) = retCPR_maybe c
returnsCPR_maybe _         = Nothing
1015 1016 1017 1018 1019

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

Gabor Greif's avatar
Gabor Greif committed
1021
-- See Notes [Default demand on free variables]
Joachim Breitner's avatar
Joachim Breitner committed
1022
-- and [defaultDmd vs. resTypeArgDmd]
1023 1024 1025
defaultDmd :: Termination r -> Demand
defaultDmd (Dunno {}) = absDmd
defaultDmd _          = botDmd  -- Diverges or ThrowsExn
Joachim Breitner's avatar
Joachim Breitner committed
1026

1027
resTypeArgDmd :: Termination r -> Demand
1028
-- TopRes and BotRes are polymorphic, so that
1029 1030
--      BotRes === (Bot -> BotRes) === ...
--      TopRes === (Top -> TopRes) === ...
1031
-- This function makes that concrete
Joachim Breitner's avatar
Joachim Breitner committed
1032
-- Also see Note [defaultDmd vs. resTypeArgDmd]
1033 1034
resTypeArgDmd (Dunno _) = topDmd
resTypeArgDmd _         = botDmd   -- Diverges or ThrowsExn
1035

Austin Seipp's avatar
Austin Seipp committed
1036
{-
Joachim Breitner's avatar
Joachim Breitner committed