Demand.hs 78.4 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
  ExnStr x -
           |
        HeadStr
        /     \
    SCall      SProd
        \      /
        HyperStr

Note [Exceptions and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
David Feuer's avatar
David Feuer committed
127 128 129
Exceptions need rather careful treatment, especially because of 'catch'
('catch#'), 'catchSTM' ('catchSTM#'), and 'orElse' ('catchRetry#').
See Trac #11555, #10712 and #13330, and for some more background, #11222.
130

David Feuer's avatar
David Feuer committed
131
There are three main pieces.
132 133 134 135 136 137 138 139 140 141 142

* 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.)

David Feuer's avatar
David Feuer committed
143
Here is the key example
144

David Feuer's avatar
David Feuer committed
145
    catchRetry# (\s -> retry# s) blah
146

David Feuer's avatar
David Feuer committed
147
We analyse the argument (\s -> retry# s) with demand
148 149 150 151
    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
David Feuer's avatar
David Feuer committed
152
    application of retry#.
153 154 155 156 157
  - Then we apply the post-processing for the shell, squashing the
    ThrowsExn to topRes.

This also applies uniformly to free variables.  Consider

David Feuer's avatar
David Feuer committed
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
    let r = \st -> retry# st
    in catchRetry# (\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 catchRetry#'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 retry just as if we'd inlined 'r'.

* We don't try to get clever about 'catch#' and 'catchSTM#' at the moment. We
previously (#11222) tried to take advantage of the fact that 'catch#' calls its
first argument eagerly. See especially commit
9915b6564403a6d17651e9969e9ea5d7d7e78e7f. We analyzed that first argument with
a strict demand, and then performed a post-processing step at the end to change
ThrowsExn to TopRes.  The trouble, I believe, is that to use this approach
correctly, we'd need somewhat different information about that argument.
Diverges, ThrowsExn (i.e., diverges or throws an exception), and Dunno are the
wrong split here.  In order to evaluate part of the argument speculatively,
we'd need to know that it *does not throw an exception*. That is, that it
either diverges or succeeds. But we don't currently have a way to talk about
that. Abstractly and approximately,

catch# m f s = case ORACLE m s of
  DivergesOrSucceeds -> m s
  Fails exc -> f exc s

where the magical ORACLE determines whether or not (m s) throws an exception
when run, and if so which one. If we want, we can safely consider (catch# m f s)
strict in anything that both branches are strict in (by performing demand
analysis for 'catch#' in the same way we do for case). We could also safely
consider it strict in anything demanded by (m s) that is guaranteed not to
throw an exception under that demand, but I don't know if we have the means
to express that.

My mind keeps turning to this model (not as an actual change to the type, but
as a way to think about what's going on in the analysis):

newtype IO a = IO {unIO :: State# s -> (# s, (# SomeException | a #) #)}
instance Monad IO where
  return a = IO $ \s -> (# s, (# | a #) #)
  IO m >>= f = IO $ \s -> case m s of
    (# s', (# e | #) #) -> (# s', e #)
    (# s', (# | a #) #) -> unIO (f a) s
raiseIO# e s = (# s, (# e | #) #)
catch# m f s = case m s of
  (# s', (# e | #) #) -> f e s'
  res -> res

Thinking about it this way seems likely to be productive for analyzing IO
exception behavior, but imprecise exceptions and asynchronous exceptions remain
quite slippery beasts. Can we incorporate them? I think we can. We can imagine
applying 'seq#' to evaluate @m s@, determining whether it throws an imprecise
or asynchronous exception or whether it succeeds or throws an IO exception.
This confines the peculiarities to 'seq#', which is indeed rather essentially
peculiar.
Austin Seipp's avatar
Austin Seipp committed
214
-}
215

216 217
-- Vanilla strictness domain
data StrDmd
Austin Seipp's avatar
Austin Seipp committed
218
  = HyperStr             -- Hyper-strict
219
                         -- Bottom of the lattice
220
                         -- Note [HyperStr and Use demands]
221 222 223 224

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

225
  | SProd [ArgStr]     -- Product
226 227
                         -- Used only for values of product type
                         -- Invariant: not all components are HyperStr (use HyperStr)
228
                         --            not all components are Lazy     (use HeadStr)
229

230
  | HeadStr              -- Head-Strict
231 232 233
                         -- A polymorphic demand: used for values of all types,
                         --                       including a type variable

234 235
  deriving ( Eq, Show )

236 237 238 239 240
type ArgStr = Str StrDmd

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

243 244 245 246 247 248 249
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 )

250
-- Well-formedness preserving constructors for the Strictness domain
251 252
strBot, strTop :: ArgStr
strBot = Str VanStr HyperStr
253 254 255 256 257 258
strTop = Lazy

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

259
mkSProd :: [ArgStr] -> StrDmd
260 261 262 263 264
mkSProd sx
  | any isHyperStr sx = HyperStr
  | all isLazy     sx = HeadStr
  | otherwise         = SProd sx

265 266 267
isLazy :: ArgStr -> Bool
isLazy Lazy     = True
isLazy (Str {}) = False
268

269 270 271
isHyperStr :: ArgStr -> Bool
isHyperStr (Str _ HyperStr) = True
isHyperStr _                = False
272 273 274 275 276

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

280 281 282
instance Outputable ArgStr where
  ppr (Str x s)     = (case x of VanStr -> empty; ExnStr -> char 'x')
                      <> ppr s
283 284
  ppr Lazy          = char 'L'

285 286 287 288 289 290 291 292
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
293

294 295 296
lubStr :: StrDmd -> StrDmd -> StrDmd
lubStr HyperStr s              = s
lubStr (SCall s1) HyperStr     = SCall s1
297
lubStr (SCall _)  HeadStr      = HeadStr
298
lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)
299 300 301
lubStr (SCall _)  (SProd _)    = HeadStr
lubStr (SProd sx) HyperStr     = SProd sx
lubStr (SProd _)  HeadStr      = HeadStr
302
lubStr (SProd s1) (SProd s2)
303
    | length s1 == length s2   = mkSProd (zipWith lubArgStr s1 s2)
304 305 306 307
    | otherwise                = HeadStr
lubStr (SProd _) (SCall _)     = HeadStr
lubStr HeadStr   _             = HeadStr

308 309 310 311 312 313 314 315
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
316 317 318

bothStr :: StrDmd -> StrDmd -> StrDmd
bothStr HyperStr _             = HyperStr
319
bothStr HeadStr s              = s
320
bothStr (SCall _)  HyperStr    = HyperStr
321
bothStr (SCall s1) HeadStr     = SCall s1
322 323 324 325
bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)
bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird

bothStr (SProd _)  HyperStr    = HyperStr
326
bothStr (SProd s1) HeadStr     = SProd s1
Austin Seipp's avatar
Austin Seipp committed
327
bothStr (SProd s1) (SProd s2)
328
    | length s1 == length s2   = mkSProd (zipWith bothArgStr s1 s2)
329 330 331
    | otherwise                = HyperStr  -- Weird
bothStr (SProd _) (SCall _)    = HyperStr

332 333 334
-- utility functions to deal with memory leaks
seqStrDmd :: StrDmd -> ()
seqStrDmd (SProd ds)   = seqStrDmdList ds
335
seqStrDmd (SCall s)    = seqStrDmd s
336 337
seqStrDmd _            = ()

338
seqStrDmdList :: [ArgStr] -> ()
339
seqStrDmdList [] = ()
340
seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds
341

342 343 344
seqArgStr :: ArgStr -> ()
seqArgStr Lazy      = ()
seqArgStr (Str x s) = x `seq` seqStrDmd s
345 346

-- Splitting polymorphic demands
347 348 349
splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]
splitArgStrProdDmd n Lazy      = Just (replicate n Lazy)
splitArgStrProdDmd n (Str _ s) = splitStrProdDmd n s
350

351
splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]
352 353
splitStrProdDmd n HyperStr   = Just (replicate n strBot)
splitStrProdDmd n HeadStr    = Just (replicate n strTop)
lukemaurer's avatar
lukemaurer committed
354 355 356
splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n),
                                     text "splitStrProdDmd" $$ ppr n $$ ppr ds )
                               Just ds
357 358 359
splitStrProdDmd _ (SCall {}) = Nothing
      -- This can happen when the programmer uses unsafeCoerce,
      -- and we don't then want to crash the compiler (Trac #9208)
360

Austin Seipp's avatar
Austin Seipp committed
361 362 363
{-
************************************************************************
*                                                                      *
364
            Absence domain
Austin Seipp's avatar
Austin Seipp committed
365 366
*                                                                      *
************************************************************************
367

368 369 370 371 372 373 374 375 376
         Used
         /   \
     UCall   UProd
         \   /
         UHead
          |
  Count x -
        |
       Abs
Austin Seipp's avatar
Austin Seipp committed
377
-}
378

379 380 381
-- Domain for genuine usage
data UseDmd
  = UCall Count UseDmd   -- Call demand for absence
382 383
                         -- Used only for values of function type

384
  | UProd [ArgUse]     -- Product
385 386 387 388 389
                         -- 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
390
  | UHead                -- May be used; but its sub-components are
391 392 393 394 395 396 397
                         -- 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

398 399 400 401
  | Used                 -- May be used; and its sub-components may be used
                         -- Top of the lattice
  deriving ( Eq, Show )

402
-- Extended usage demand for absence and counting
403 404 405 406 407
type ArgUse = Use UseDmd

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

409
  | Use Count u     -- May be used with some cardinality
410 411 412 413
  deriving ( Eq, Show )

-- Abstract counting of usages
data Count = One | Many
Austin Seipp's avatar
Austin Seipp committed
414
  deriving ( Eq, Show )
415 416

-- Pretty-printing
417
instance Outputable ArgUse where
418
  ppr Abs           = char 'A'
Austin Seipp's avatar
Austin Seipp committed
419
  ppr (Use Many a)   = ppr a
420 421 422 423 424 425 426 427 428 429 430
  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 ""
431

432
useBot, useTop :: ArgUse
433 434 435 436
useBot     = Abs
useTop     = Use Many Used

mkUCall :: Count -> UseDmd -> UseDmd
Austin Seipp's avatar
Austin Seipp committed
437
--mkUCall c Used = Used c
438 439
mkUCall c a  = UCall c a

440
mkUProd :: [ArgUse] -> UseDmd
Austin Seipp's avatar
Austin Seipp committed
441
mkUProd ux
442 443 444
  | all (== Abs) ux    = UHead
  | otherwise          = UProd ux

445 446 447
lubCount :: Count -> Count -> Count
lubCount _ Many = Many
lubCount Many _ = Many
Austin Seipp's avatar
Austin Seipp committed
448
lubCount x _    = x
449

450 451 452 453
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)
454 455 456 457 458 459

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
460
lubUse (UProd ux) UHead            = UProd ux
461
lubUse (UProd ux1) (UProd ux2)
462
     | length ux1 == length ux2    = UProd $ zipWith lubArgUse ux1 ux2
463 464 465
     | otherwise                   = Used
lubUse (UProd {}) (UCall {})       = Used
-- lubUse (UProd {}) Used             = Used
466 467
lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)
lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)
468 469 470 471
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
472
--  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).
473 474
--  Also,  x `bothUse` x /= x (for anything but Abs).

475 476 477 478
bothArgUse :: ArgUse -> ArgUse -> ArgUse
bothArgUse Abs x                   = x
bothArgUse x Abs                   = x
bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)
479 480 481 482 483 484


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

Austin Seipp's avatar
Austin Seipp committed
485
-- Exciting special treatment of inner demand for call demands:
486 487 488 489
--    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
490
bothUse (UProd ux) UHead            = UProd ux
491
bothUse (UProd ux1) (UProd ux2)
492
      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2
493 494 495
      | otherwise                   = Used
bothUse (UProd {}) (UCall {})       = Used
-- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
496 497
bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)
bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)
498 499 500 501 502
bothUse Used _                      = Used  -- Note [Used should win]

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

504 505 506 507
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]
508
addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds
509 510 511 512
  = case mu of
     Abs     -> alt_dmds
     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
             where
513
                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call
514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
                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 }

540
It's true that ds_dnz is *itself* absent, but the use of wild_X7 means
541 542 543 544 545 546
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.

547 548 549 550 551 552 553 554
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
555
would get
556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574
  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
575
unboxed, then we are definitely using the box, and so we are quite
576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592
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
593
-}
594

595 596
-- 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.
597
markReusedDmd :: ArgUse -> ArgUse
598 599
markReusedDmd Abs         = Abs
markReusedDmd (Use _ a)   = Use Many (markReused a)
600

601 602 603 604
markReused :: UseDmd -> UseDmd
markReused (UCall _ u)      = UCall Many u   -- No need to recurse here
markReused (UProd ux)       = UProd (map markReusedDmd ux)
markReused u                = u
605

606
isUsedMU :: ArgUse -> Bool
607
-- True <=> markReusedDmd d = d
608 609 610 611 612
isUsedMU Abs          = True
isUsedMU (Use One _)  = False
isUsedMU (Use Many u) = isUsedU u

isUsedU :: UseDmd -> Bool
613
-- True <=> markReused d = d
614 615 616 617 618 619 620 621
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 -> ()
622
seqUseDmd (UProd ds)   = seqArgUseList ds
623 624 625
seqUseDmd (UCall c d)  = c `seq` seqUseDmd d
seqUseDmd _            = ()

626 627 628
seqArgUseList :: [ArgUse] -> ()
seqArgUseList []     = ()
seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds
629

630 631 632
seqArgUse :: ArgUse -> ()
seqArgUse (Use c u)  = c `seq` seqUseDmd u
seqArgUse _          = ()
633 634

-- Splitting polymorphic Maybe-Used demands
635
splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]
636 637
splitUseProdDmd n Used        = Just (replicate n useTop)
splitUseProdDmd n UHead       = Just (replicate n Abs)
lukemaurer's avatar
lukemaurer committed
638 639 640
splitUseProdDmd n (UProd ds)  = WARN( not (ds `lengthIs` n),
                                      text "splitUseProdDmd" $$ ppr n
                                                             $$ ppr ds )
641 642 643 644
                                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)
645

646 647 648 649
useCount :: Use u -> Count
useCount Abs         = One
useCount (Use One _) = One
useCount _           = Many
650 651


Austin Seipp's avatar
Austin Seipp committed
652 653 654
{-
************************************************************************
*                                                                      *
655
         Clean demand for Strictness and Usage
Austin Seipp's avatar
Austin Seipp committed
656 657
*                                                                      *
************************************************************************
658

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

662 663
Note [Strict demands]
~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
664
isStrictDmd returns true only of demands that are
665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680
   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}]

681 682 683 684 685 686 687 688 689 690
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
691
-}
692

693 694
type CleanDemand = JointDmd StrDmd UseDmd
     -- A demand that is at least head-strict
695 696

bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
697 698
bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})
  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }
699 700

mkHeadStrict :: CleanDemand -> CleanDemand
701
mkHeadStrict cd = cd { sd = HeadStr }
702

703 704 705
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 }
706

707
evalDmd :: Demand
708
-- Evaluated strictly, and used arbitrarily deeply
709
evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }
710

711
mkProdDmd :: [Demand] -> CleanDemand
Austin Seipp's avatar
Austin Seipp committed
712
mkProdDmd dx
713 714
  = JD { sd = mkSProd $ map getStrDmd dx
       , ud = mkUProd $ map getUseDmd dx }
715 716

mkCallDmd :: CleanDemand -> CleanDemand
717 718
mkCallDmd (JD {sd = d, ud = u})
  = JD { sd = mkSCall d, ud = mkUCall One u }
719

720 721 722 723 724 725
-- 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)

726
cleanEvalDmd :: CleanDemand
727
cleanEvalDmd = JD { sd = HeadStr, ud = Used }
728 729

cleanEvalProdDmd :: Arity -> CleanDemand
730
cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }
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
{-
************************************************************************
*                                                                      *
           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) }

David Feuer's avatar
David Feuer committed
758
-- First argument of catchRetry# and catchSTM#:
759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830
--    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
831 832 833 834
  | 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
835 836 837 838 839 840
  | 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 }) )
841 842 843 844 845 846

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

instance Outputable TypeShape where
847 848
  ppr TsUnk        = text "TsUnk"
  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
849 850
  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)

851
trimToType :: Demand -> TypeShape -> Demand
852
-- See Note [Trimming a demand to a type]
853
trimToType (JD { sd = ms, ud = mu }) ts
854 855
  = JD (go_ms ms ts) (go_mu mu ts)
  where
856 857 858
    go_ms :: ArgStr -> TypeShape -> ArgStr
    go_ms Lazy      _  = Lazy
    go_ms (Str x s) ts = Str x (go_s s ts)
859 860 861 862 863 864 865 866

    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

867
    go_mu :: ArgUse -> TypeShape -> ArgUse
868 869 870 871 872 873 874 875 876
    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
877

Austin Seipp's avatar
Austin Seipp committed
878
{-
879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899
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.


900 901 902 903 904 905
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].

906 907 908
Note [Replicating polymorphic demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some demands can be considered as polymorphic. Generally, it is
Gabor Greif's avatar
Gabor Greif committed
909
applicable to such beasts as tops, bottoms as well as Head-Used and
910 911 912 913 914
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
915 916
can be expanded to saturate a callee's arity.
-}
917

918
splitProdDmd_maybe :: Demand -> Maybe [Demand]
919 920 921
-- Split a product into its components, iff there is any
-- useful information to be extracted thereby
-- The demand is not necessarily strict!
922
splitProdDmd_maybe (JD { sd = s, ud = u })
923
  = case (s,u) of
924 925 926 927 928
      (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)
929
      _ -> Nothing
930

Austin Seipp's avatar
Austin Seipp committed
931 932 933
{-
************************************************************************
*                                                                      *
934
                   Demand results
Austin Seipp's avatar
Austin Seipp committed
935 936
*                                                                      *
************************************************************************
937

938 939 940

DmdResult:     Dunno CPRResult
               /
941 942
           ThrowsExn
             /
943 944 945 946 947 948 949 950
        Diverges


CPRResult:         NoCPR
                   /    \
            RetProd    RetSum ConTag


Gabor Greif's avatar
Gabor Greif committed
951
Product constructors return (Dunno (RetProd rs))
952 953
In a fixpoint iteration, start from Diverges
We have lubs, but not glbs; but that is ok.
Austin Seipp's avatar
Austin Seipp committed
954
-}
955

956
------------------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
957
-- Constructed Product Result
958 959
------------------------------------------------------------------------

960 961 962 963 964
data Termination r
  = Diverges    -- Definitely diverges
  | ThrowsExn   -- Definitely throws an exception or diverges
  | Dunno r     -- Might diverge or converge
  deriving( Eq, Show )
965

966 967 968 969 970
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
971 972
               deriving( Eq, Show )

973
lubCPR :: CPRResult -> CPRResult -> CPRResult
Austin Seipp's avatar
Austin Seipp committed
974
lubCPR (RetSum t1) (RetSum t2)
975
  | t1 == t2                       = RetSum t1
976 977
lubCPR RetProd     RetProd     = RetProd
lubCPR _ _                     = NoCPR
978 979 980

lubDmdResult :: DmdResult -> DmdResult -> DmdResult
lubDmdResult Diverges       r              = r
981 982
lubDmdResult ThrowsExn      Diverges       = ThrowsExn
lubDmdResult ThrowsExn      r              = r
983
lubDmdResult (Dunno c1)     Diverges       = Dunno c1
984
lubDmdResult (Dunno c1)     ThrowsExn      = Dunno c1
985
lubDmdResult (Dunno c1)     (Dunno c2)     = Dunno (c1 `lubCPR` c2)
986
-- This needs to commute with defaultDmd, i.e.
987
-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
988
-- (See Note [Default demand on free variables] for why)
989

990
bothDmdResult :: DmdResult -> Termination () -> DmdResult
991
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
992 993 994
bothDmdResult _ Diverges   = Diverges
bothDmdResult r ThrowsExn  = case r of { Diverges -> r; _ -> ThrowsExn }
bothDmdResult r (Dunno {}) = r
995
-- This needs to commute with defaultDmd, i.e.
996
-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
997
-- (See Note [Default demand on free variables] for why)
998

999
instance Outputable r => Outputable (Termination r) where
1000
  ppr Diverges      = char 'b'
1001
  ppr ThrowsExn     = char 'x'
1002
  ppr (Dunno c)     = ppr c
1003

1004 1005 1006 1007
instance Outputable CPRResult where
  ppr NoCPR        = empty
  ppr (RetSum n)   = char 'm' <> int n
  ppr RetProd      = char 'm'
1008

1009
seqDmdResult :: DmdResult -> ()
1010 1011 1012
seqDmdResult Diverges  = ()
seqDmdResult ThrowsExn = ()
seqDmdResult (Dunno c) = seqCPRResult c
1013

1014 1015 1016 1017
seqCPRResult :: CPRResult -> ()
seqCPRResult NoCPR        = ()
seqCPRResult (RetSum n)   = n `seq` ()
seqCPRResult RetProd      = ()
1018

1019 1020 1021 1022

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