DmdAnal.hs 57.4 KB
Newer Older
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

4

5 6 7
                        -----------------
                        A demand analysis
                        -----------------
8
-}
9

10
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
11

12
module DmdAnal ( dmdAnalProgram ) where
13 14 15

#include "HsVersions.h"

16
import DynFlags
17
import WwLib            ( findTypeShape, deepSplitProductType_maybe )
18
import Demand   -- All of it
19
import CoreSyn
20
import Outputable
21
import VarEnv
22
import BasicTypes
23
import Data.List
24
import DataCon
25
import Id
26
import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial )
27
import TyCon
28
import Type
29
import Coercion         ( Coercion, coVarsOfCo )
30
import FamInstEnv
31
import Util
32
import Maybes           ( isJust )
33
import TysWiredIn
34
import TysPrim          ( realWorldStatePrimTy )
Joachim Breitner's avatar
Joachim Breitner committed
35
import ErrUtils         ( dumpIfSet_dyn )
36 37
import Name             ( getName, stableNameCmp )
import Data.Function    ( on )
38

39 40 41
{-
************************************************************************
*                                                                      *
42
\subsection{Top level stuff}
43 44 45
*                                                                      *
************************************************************************
-}
46

47 48
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram dflags fam_envs binds
49
  = do {
50
        let { binds_plus_dmds = do_prog binds } ;
manav's avatar
manav committed
51 52
        dumpIfSet_dyn dflags Opt_D_dump_str_signatures
                      "Strictness signatures" $
Joachim Breitner's avatar
Joachim Breitner committed
53
            dumpStrSig binds_plus_dmds ;
54
        return binds_plus_dmds
55 56
    }
  where
57
    do_prog :: CoreProgram -> CoreProgram
58
    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds
59

60
-- Analyse a (group of) top-level binding(s)
61
dmdAnalTopBind :: AnalEnv
62 63
               -> CoreBind
               -> (AnalEnv, CoreBind)
64
dmdAnalTopBind sigs (NonRec id rhs)
65
  = (extendAnalEnv TopLevel sigs id2 (idStrictness id2), NonRec id2 rhs2)
66
  where
67 68
    ( _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs             id rhs
    ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1
69
        -- Do two passes to improve CPR information
70 71 72
        -- See Note [CPR for thunks]
        -- See Note [Optimistic CPR in the "virgin" case]
        -- See Note [Initial CPR for strict binders]
73

74
dmdAnalTopBind sigs (Rec pairs)
75 76
  = (sigs', Rec pairs')
  where
77
    (sigs', _, pairs')  = dmdFix TopLevel sigs pairs
78 79
                -- We get two iterations automatically
                -- c.f. the NonRec case above
80

81 82 83
{-
************************************************************************
*                                                                      *
84
\subsection{The analyser itself}
85 86
*                                                                      *
************************************************************************
87

88 89 90
Note [Ensure demand is strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important not to analyse e with a lazy demand because
91 92 93 94
a) When we encounter   case s of (a,b) ->
        we demand s with U(d1d2)... but if the overall demand is lazy
        that is wrong, and we'd need to reduce the demand on s,
        which is inconvenient
95
b) More important, consider
96
        f (let x = R in x+x), where f is lazy
97 98 99 100 101 102
   We still want to mark x as demanded, because it will be when we
   enter the let.  If we analyse f's arg with a Lazy demand, we'll
   just mark x as Lazy
c) The application rule wouldn't be right either
   Evaluating (f x) in a L demand does *not* cause
   evaluation of f in a C(L) demand!
103
-}
104

105 106 107 108 109 110
-- If e is complicated enough to become a thunk, its contents will be evaluated
-- at most once, so oneify it.
dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
dmdTransformThunkDmd e
  | exprIsTrivial e = id
  | otherwise       = oneifyDmd
111 112 113 114

-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
-- See |-* relation in the companion paper
115 116
dmdAnalStar :: AnalEnv
            -> Demand   -- This one takes a *Demand*
117
            -> CoreExpr -> (BothDmdArg, CoreExpr)
118
dmdAnalStar env dmd e
119
  | (defer_and_use, cd) <- toCleanDmd dmd (exprType e)
120
  , (dmd_ty, e')        <- dmdAnal env cd e
121
  = (postProcessDmdType defer_and_use dmd_ty, e')
122 123

-- Main Demand Analsysis machinery
Simon Peyton Jones's avatar
Simon Peyton Jones committed
124
dmdAnal, dmdAnal' :: AnalEnv
125
        -> CleanDemand         -- The main one takes a *CleanDemand*
126 127 128 129 130
        -> CoreExpr -> (DmdType, CoreExpr)

-- The CleanDemand is always strict and not absent
--    See Note [Ensure demand is strict]

Simon Peyton Jones's avatar
Simon Peyton Jones committed
131 132
dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                  dmdAnal' env d e
133

Simon Peyton Jones's avatar
Simon Peyton Jones committed
134
dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
135
dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
136 137
dmdAnal' _ _ (Coercion co)
  = (unitDmdType (coercionDmdEnv co), Coercion co)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
138 139

dmdAnal' env dmd (Var var)
140
  = (dmdTransform env var dmd, Var var)
141

Simon Peyton Jones's avatar
Simon Peyton Jones committed
142
dmdAnal' env dmd (Cast e co)
143
  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
144
  where
145 146 147
    (dmd_ty, e') = dmdAnal env dmd e

{-       ----- I don't get this, so commenting out -------
148
    to_co        = pSnd (coercionKind co)
149
    dmd'
150
      | Just tc <- tyConAppTyCon_maybe to_co
151
      , isRecursiveTyCon tc = cleanEvalDmd
152
      | otherwise           = dmd
153
        -- This coerce usually arises from a recursive
154
        -- newtype, and we don't want to look inside them
155 156 157
        -- for exactly the same reason that we don't look
        -- inside recursive products -- we might not reach
        -- a fixpoint.  So revert to a vanilla Eval demand
158
-}
159

Simon Peyton Jones's avatar
Simon Peyton Jones committed
160
dmdAnal' env dmd (Tick t e)
161
  = (dmd_ty, Tick t e')
162
  where
163
    (dmd_ty, e') = dmdAnal env dmd e
164

Simon Peyton Jones's avatar
Simon Peyton Jones committed
165
dmdAnal' env dmd (App fun (Type ty))
166
  = (fun_ty, App fun' (Type ty))
167
  where
168
    (fun_ty, fun') = dmdAnal env dmd fun
169

170 171
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
172
dmdAnal' env dmd (App fun arg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
173 174 175 176
  = -- This case handles value arguments (type args handled above)
    -- Crucially, coercions /are/ handled here, because they are
    -- value arguments (Trac #10288)
    let
177
        call_dmd          = mkCallDmd dmd
178 179 180
        (fun_ty, fun')    = dmdAnal env call_dmd fun
        (arg_dmd, res_ty) = splitDmdTy fun_ty
        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
181
    in
182 183 184 185 186 187 188 189 190
--    pprTrace "dmdAnal:app" (vcat
--         [ text "dmd =" <+> ppr dmd
--         , text "expr =" <+> ppr (App fun arg)
--         , text "fun dmd_ty =" <+> ppr fun_ty
--         , text "arg dmd =" <+> ppr arg_dmd
--         , text "arg dmd_ty =" <+> ppr arg_ty
--         , text "res dmd_ty =" <+> ppr res_ty
--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
    (res_ty `bothDmdType` arg_ty, App fun' arg')
191

192
-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
Simon Peyton Jones's avatar
Simon Peyton Jones committed
193
dmdAnal' env dmd (Lam var body)
194
  | isTyVar var
195 196
  = let
        (body_ty, body') = dmdAnal env dmd body
197
    in
198
    (body_ty, Lam var body')
199

200
  | otherwise
201 202 203
  = let (body_dmd, defer_and_use) = peelCallDmd dmd
          -- body_dmd: a demand to analyze the body

204 205
        env'             = extendSigsWithLam env var
        (body_ty, body') = dmdAnal env' body_dmd body
206
        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var
207
    in
208
    (postProcessUnsat defer_and_use lam_ty, Lam var' body')
209

210
dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
211
  -- Only one alternative with a product constructor
212
  | let tycon = dataConTyCon dc
213
  , isJust (isDataProductTyCon_maybe tycon)
214
  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
215
  = let
216 217 218 219 220 221
        env_w_tc                 = env { ae_rec_tc = rec_tc' }
        env_alt                  = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs
        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs
        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
222 223
        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
                | otherwise                   = alt_ty2
224

225 226 227
        -- Compute demand on the scrutinee
        -- See Note [Demand on scrutinee of a product case]
        scrut_dmd          = mkProdDmd (addDataConStrictness dc id_dmds)
228
        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
229 230 231
        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty
        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd
        bndrs'             = setBndrsDemandInfo bndrs id_dmds
232
    in
233
--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
234 235 236 237
--                                   , text "dmd" <+> ppr dmd
--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
--                                   , text "scrut_dmd" <+> ppr scrut_dmd
--                                   , text "scrut_ty" <+> ppr scrut_ty
238
--                                   , text "alt_ty" <+> ppr alt_ty2
239
--                                   , text "res_ty" <+> ppr res_ty ]) $
240
    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])
241

Simon Peyton Jones's avatar
Simon Peyton Jones committed
242
dmdAnal' env dmd (Case scrut case_bndr ty alts)
243
  = let      -- Case expression with multiple alternatives
244
        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
245 246
        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
247 248 249
                               -- NB: Base case is botDmdType, for empty case alternatives
                               --     This is a unit for lubDmdType, and the right result
                               --     when there really are no alternatives
250
        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
251
    in
252 253
--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "scrut_ty" <+> ppr scrut_ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
254
--                                   , text "alt_tys" <+> ppr alt_tys
255 256 257
--                                   , text "alt_ty" <+> ppr alt_ty
--                                   , text "res_ty" <+> ppr res_ty ]) $
    (res_ty, Case scrut' case_bndr' ty alts')
258

259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
-- Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- The following case handle the up variant.
--
-- It is very simple. For  let x = rhs in body
--   * Demand-analyse 'body' in the current environment
--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
--   * Demand-analyse 'rhs' in 'rhs_dmd'
--
-- This is used for a non-recursive local let without manifest lambdas.
-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnal' env dmd (Let (NonRec id rhs) body)
  | useLetUp rhs
  , Nothing <- unpackTrivial rhs
      -- dmdAnalRhsLetDown treats trivial right hand sides specially
      -- so if we have a trival right hand side, fall through to that.
  = (final_ty, Let (NonRec id' rhs') body')
  where
    (body_ty, body')   = dmdAnal env dmd body
    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
    id'                = setIdDemandInfo id id_dmd

    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
    final_ty           = body_ty' `bothDmdType` rhs_ty

Simon Peyton Jones's avatar
Simon Peyton Jones committed
284
dmdAnal' env dmd (Let (NonRec id rhs) body)
285
  = (body_ty2, Let (NonRec id2 rhs') body')
286
  where
287 288 289 290 291
    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs
    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
    (body_ty, body')     = dmdAnal env1 dmd body
    (body_ty1, id2)      = annotateBndr env body_ty id1
    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables]
292

293 294 295 296 297 298 299 300 301 302 303 304
        -- If the actual demand is better than the vanilla call
        -- demand, you might think that we might do better to re-analyse
        -- the RHS with the stronger demand.
        -- But (a) That seldom happens, because it means that *every* path in
        --         the body of the let has to use that stronger demand
        -- (b) It often happens temporarily in when fixpointing, because
        --     the recursive function at first seems to place a massive demand.
        --     But we don't want to go to extra work when the function will
        --     probably iterate to something less demanding.
        -- In practice, all the times the actual demand on id2 is more than
        -- the vanilla call demand seem to be due to (b).  So we don't
        -- bother to re-analyse the RHS.
305

Simon Peyton Jones's avatar
Simon Peyton Jones committed
306
dmdAnal' env dmd (Let (Rec pairs) body)
307
  = let
308 309
        (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
        (body_ty, body')        = dmdAnal env' dmd body
310
        body_ty1                = deleteFVs body_ty (map fst pairs)
311
        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables]
312
    in
313
    body_ty2 `seq`
314
    (body_ty2,  Let (Rec pairs') body')
315

316 317 318
io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
-- See Note [IO hack in the demand analyser]
io_hack_reqd scrut con bndrs
319
  | (bndr:_) <- bndrs
320
  , con == tupleDataCon Unboxed 2
321 322 323 324 325
  , idType bndr `eqType` realWorldStatePrimTy
  , (fun, _) <- collectArgs scrut
  = case fun of
      Var f -> not (isPrimOpId f)
      _     -> True
326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
  | otherwise
  = False

dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
  | null bndrs    -- Literals, DEFAULT, and nullary constructors
  , (rhs_ty, rhs') <- dmdAnal env dmd rhs
  = (rhs_ty, (con, [], rhs'))

  | otherwise     -- Non-nullary data constructors
  , (rhs_ty, rhs') <- dmdAnal env dmd rhs
  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs
  , let case_bndr_dmd = findIdDemand alt_ty case_bndr
        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds
  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))

342 343 344 345 346

{- Note [IO hack in the demand analyser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's a hack here for I/O operations.  Consider
     case foo x s of { (# s, r #) -> y }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
347
Is this strict in 'y'?  Normally yes, but what if 'foo' is an I/O
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
operation that simply terminates the program (not in an erroneous way)?
In that case we should not evaluate 'y' before the call to 'foo'.
Hackish solution: spot the IO-like situation and add a virtual branch,
as if we had
     case foo x s of
        (# s, r #) -> y
        other      -> return ()
So the 'y' isn't necessarily going to be evaluated

A more complete example (Trac #148, #1592) where this shows up is:
     do { let len = <expensive> ;
        ; when (...) (exitWith ExitSuccess)
        ; print len }

However, consider
  f x s = case getMaskingState# s of
            (# s, r #) ->
          case x of I# x2 -> ...

Here it is terribly sad to make 'f' lazy in 's'.  After all,
getMaskingState# is not going to diverge or throw an exception!  This
situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
Simon Peyton Jones's avatar
Simon Peyton Jones committed
370
(on an MVar not an Int), and made a material difference.
371 372 373 374 375 376

So if the scrutinee is a primop call, we *don't* apply the
state hack:
  - If is a simple, terminating one like getMaskingState,
    applying the hack is over-conservative.
  - If the primop is raise# then it returns bottom, so
Simon Peyton Jones's avatar
Simon Peyton Jones committed
377
    the case alternatives are already discarded.
378 379 380 381 382 383
  - If the primop can raise a non-IO exception, like
    divide by zero or seg-fault (eg writing an array
    out of bounds) then we don't mind evaluating 'x' first.

Note [Demand on the scrutinee of a product case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384 385 386 387 388 389 390 391 392 393
When figuring out the demand on the scrutinee of a product case,
we use the demands of the case alternative, i.e. id_dmds.
But note that these include the demand on the case binder;
see Note [Demand on case-alternative binders] in Demand.hs.
This is crucial. Example:
   f x = case x of y { (a,b) -> k y a }
If we just take scrut_demand = U(L,A), then we won't pass x to the
worker, so the worker will rebuild
     x = (a, absent-error)
and that'll crash.
394

395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415
Note [Aggregated demand for cardinality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use different strategies for strictness and usage/cardinality to
"unleash" demands captured on free variables by bindings. Let us
consider the example:

f1 y = let {-# NOINLINE h #-}
           h = y
       in  (h, h)

We are interested in obtaining cardinality demand U1 on |y|, as it is
used only in a thunk, and, therefore, is not going to be updated any
more. Therefore, the demand on |y|, captured and unleashed by usage of
|h| is U1. However, if we unleash this demand every time |h| is used,
and then sum up the effects, the ultimate demand on |y| will be U1 +
U1 = U. In order to avoid it, we *first* collect the aggregate demand
on |h| in the body of let-expression, and only then apply the demand
transformer:

transf[x](U) = {y |-> U1}

416
so the resulting demand on |y| is U1.
417 418 419 420 421

The situation is, however, different for strictness, where this
aggregating approach exhibits worse results because of the nature of
|both| operation for strictness. Consider the example:

422
f y c =
423
  let h x = y |seq| x
424
   in case of
425 426 427 428 429 430 431 432 433 434
        True  -> h True
        False -> y

It is clear that |f| is strict in |y|, however, the suggested analysis
will infer from the body of |let| that |h| is used lazily (as it is
used in one branch only), therefore lazy demand will be put on its
free variable |y|. Conversely, if the demand on |h| is unleashed right
on the spot, we will get the desired result, namely, that |f| is
strict in |y|.

435

436 437
************************************************************************
*                                                                      *
438
                    Demand transformer
439 440 441
*                                                                      *
************************************************************************
-}
442

443 444 445 446 447 448
dmdTransform :: AnalEnv         -- The strictness environment
             -> Id              -- The function
             -> CleanDemand     -- The demand on the function
             -> DmdType         -- The demand type of the function in this context
        -- Returned DmdEnv includes the demand on
        -- this function plus demand on its free variables
449

450
dmdTransform env var dmd
451
  | isDataConWorkId var                          -- Data constructor
452
  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
453

454 455 456 457
  | gopt Opt_DmdTxDictSel (ae_dflags env),
    Just _ <- isClassOpId_maybe var -- Dictionary component selector
  = dmdTransformDictSelSig (idStrictness var) dmd

458
  | isGlobalId var                               -- Imported function
459
  = let res = dmdTransformSig (idStrictness var) dmd in
460
--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
461
    res
462 463 464

  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
  , let fn_ty = dmdTransformSig sig dmd
465 466
  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
    if isTopLevel top_lvl
467 468
    then fn_ty   -- Don't record top level things
    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
469

470
  | otherwise                                    -- Local non-letrec-bound thing
471
  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
472

473 474 475
{-
************************************************************************
*                                                                      *
476
\subsection{Bindings}
477 478 479
*                                                                      *
************************************************************************
-}
480 481

-- Recursive bindings
482
dmdFix :: TopLevelFlag
483
       -> AnalEnv                            -- Does not include bindings for this binding
484
       -> [(Id,CoreExpr)]
485
       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
486

487
dmdFix top_lvl env orig_pairs
488
  = loop 1 initial_pairs
489
  where
490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513
    bndrs = map fst orig_pairs

    -- See Note [Initialising strictness]
    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]

                  | otherwise     = orig_pairs

    -- If fixed-point iteration does not yield a result we use this instead
    -- See Note [Safe abortion in the fixed-point iteration]
    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
    abort = (env, lazy_fv', zapped_pairs)
      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
            -- Note [Lazy and unleasheable free variables]
            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
            zapped_pairs = zapIdStrictness pairs'

    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
    -- annotation does not change any more.
    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
    loop n pairs
      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
      | n == 10        = abort
      | otherwise      = loop (n+1) pairs'
514
      where
515 516 517 518
        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
        first_round       = n == 1
        (lazy_fv, pairs') = step first_round pairs
        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
519

520 521 522 523 524 525 526 527 528 529
    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
    step first_round pairs = (lazy_fv, pairs')
      where
        -- In all but the first iteration, delete the virgin flag
        start_env | first_round = env
                  | otherwise   = nonVirgin env

        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)

        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
530 531 532
                -- mapAccumL: Use the new signature to do the next pair
                -- The occurrence analyser has arranged them in a good order
                -- so this can significantly reduce the number of iterations needed
533

534 535
        my_downRhs (env, lazy_fv) (id,rhs)
          = ((env', lazy_fv'), (id', rhs'))
536
          where
537 538 539
            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs
            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
540

541

542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561
    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]

{-
Note [Safe abortion in the fixed-point iteration]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Fixed-point iteration may fail to terminate. But we cannot simply give up and
return the environment and code unchanged! We still need to do one additional
round, for two reasons:

 * To get information on used free variables (both lazy and strict!)
   (see Note [Lazy and unleasheable free variables])
 * To ensure that all expressions have been traversed at least once, and any left-over
   strictness annotations have been updated.

This final iteration does not add the variables to the strictness signature
environment, which effectively assigns them 'nopSig' (see "getStrictness")

-}
562 563 564 565 566

-- Trivial RHS
-- See Note [Demand analysis for trivial right-hand sides]
dmdAnalTrivialRhs ::
    AnalEnv -> Id -> CoreExpr -> Var ->
567
    (DmdEnv, Id, CoreExpr)
568
dmdAnalTrivialRhs env id rhs fn
569
  = (fn_fv, set_idStrictness env id fn_str, rhs)
570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594
  where
    fn_str = getStrictness env fn
    fn_fv | isLocalId fn = unitVarEnv fn topDmd
          | otherwise    = emptyDmdEnv
    -- Note [Remember to demand the function itself]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- fn_fv: don't forget to produce a demand for fn itself
    -- Lacking this caused Trac #9128
    -- The demand is very conservative (topDmd), but that doesn't
    -- matter; trivial bindings are usually inlined, so it only
    -- kicks in for top-level bindings and NOINLINE bindings

-- Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- dmdAnalRhsLetDown implements the Down variant:
--  * assuming a demand of <L,U>
--  * looking at the definition
--  * determining a strictness signature
--
-- It is used for toplevel definition, recursive definitions and local
-- non-recursive definitions that have manifest lambdas.
-- Local non-recursive definitions without a lambda are handled with LetUp.
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalRhsLetDown :: TopLevelFlag
595
           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
596
           -> AnalEnv -> Id -> CoreExpr
597
           -> (DmdEnv, Id, CoreExpr)
598 599
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
600
dmdAnalRhsLetDown top_lvl rec_flag env id rhs
601
  | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]
602
  = dmdAnalTrivialRhs env id rhs fn
603 604

  | otherwise
605
  = (lazy_fv, id', mkLams bndrs' body')
606
  where
607 608 609 610 611 612 613
    (bndrs, body)    = collectBinders rhs
    env_body         = foldl extendSigsWithLam env bndrs
    (body_ty, body') = dmdAnal env_body body_dmd body
    body_ty'         = removeDmdTyArgs body_ty -- zap possible deep CPR info
    (DmdType rhs_fv rhs_dmds rhs_res, bndrs')
                     = annotateLamBndrs env (isDFunId id) body_ty' bndrs
    sig_ty           = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
614 615
    id'              = set_idStrictness env id sig_ty
        -- See Note [NOINLINE and strictness]
616 617

    -- See Note [Product demands for function body]
618
    body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
619 620 621 622 623
                 Nothing            -> cleanEvalDmd
                 Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)

    -- See Note [Aggregated demand for cardinality]
    rhs_fv1 = case rec_flag of
624
                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
625 626
                Nothing -> rhs_fv

627
    -- See Note [Lazy and unleashable free variables]
628 629
    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1

630 631 632
    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res
    trim_all  = is_thunk && not_strict
    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
633

634 635
    -- See Note [CPR for thunks]
    is_thunk = not (exprIsHNF rhs)
636 637
    not_strict
       =  isTopLevel top_lvl  -- Top level and recursive things don't
638 639 640
       || isJust rec_flag     -- get their demandInfo set at all
       || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
          -- See Note [Optimistic CPR in the "virgin" case]
641 642 643

unpackTrivial :: CoreExpr -> Maybe Id
-- Returns (Just v) if the arg is really equal to v, modulo
644
-- casts, type applications etc
645
-- See Note [Demand analysis for trivial right-hand sides]
646 647 648 649 650
unpackTrivial (Var v)                 = Just v
unpackTrivial (Cast e _)              = unpackTrivial e
unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e
unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
unpackTrivial _                       = Nothing
651

652 653 654 655 656 657 658 659 660 661 662 663
-- | If given the RHS of a let-binding, this 'useLetUp' determines
-- whether we should process the binding up (body before rhs) or
-- down (rhs before body).
--
-- We use LetDown if there is a chance to get a useful strictness signature.
-- This is the case when there are manifest value lambdas.
useLetUp :: CoreExpr -> Bool
useLetUp (Lam v e) | isTyVar v = useLetUp e
useLetUp (Lam _ _)             = False
useLetUp _                     = True


664
{-
665 666
Note [Demand analysis for trivial right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
667
Consider
668
        foo = plusInt |> co
669 670
where plusInt is an arity-2 function with known strictness.  Clearly
we want plusInt's strictness to propagate to foo!  But because it has
671 672
no manifest lambdas, it won't do so automatically, and indeed 'co' might
have type (Int->Int->Int) ~ T, so we *can't* eta-expand.  So we have a
673
special case for right-hand sides that are "trivial", namely variables,
674 675 676 677 678 679 680 681
casts, type applications, and the like.

Note that this can mean that 'foo' has an arity that is smaller than that
indicated by its demand info.  e.g. if co :: (Int->Int->Int) ~ T, then
foo's arity will be zero (see Note [exprArity invariant] in CoreArity),
but its demand signature will be that of plusInt. A small example is the
test case of Trac #8963.

682

683 684 685 686 687
Note [Product demands for function body]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This example comes from shootout/binary_trees:

    Main.check' = \ b z ds. case z of z' { I# ip ->
688 689 690 691 692 693 694 695 696 697 698
                                case ds_d13s of
                                  Main.Nil -> z'
                                  Main.Node s14k s14l s14m ->
                                    Main.check' (not b)
                                      (Main.check' b
                                         (case b {
                                            False -> I# (-# s14h s14k);
                                            True  -> I# (+# s14h s14k)
                                          })
                                         s14l)
                                     s14m   }   }   }
699 700 701

Here we *really* want to unbox z, even though it appears to be used boxed in
the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
702
the whole function gets the CPR property if we do.
703 704 705 706

So for the demand on the body of a RHS we use a product demand if it's
a product type.

707 708
************************************************************************
*                                                                      *
709
\subsection{Strictness signatures and types}
710 711 712
*                                                                      *
************************************************************************
-}
713

714 715 716 717 718 719
unitDmdType :: DmdEnv -> DmdType
unitDmdType dmd_env = DmdType dmd_env [] topRes

coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv co = mapVarEnv (const topDmd) (coVarsOfCo co)
                    -- The VarSet from coVarsOfCo is really a VarEnv Var
720 721 722 723 724 725

addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd (DmdType fv ds res) var dmd
  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res

addLazyFVs :: DmdType -> DmdEnv -> DmdType
726
addLazyFVs dmd_ty lazy_fvs
727
  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
728
        -- Using bothDmdType (rather than just both'ing the envs)
729
        -- is vital.  Consider
730 731 732 733 734 735
        --      let f = \x -> (x,y)
        --      in  error (f 3)
        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
        -- demand with the bottom coming up from 'error'
        --
        -- I got a loop in the fixpointer without this, due to an interaction
736
        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was
737 738 739 740 741 742 743 744 745 746 747 748 749 750
        --      letrec f n x
        --          = letrec g y = x `fatbar`
        --                         letrec h z = z + ...g...
        --                         in h (f (n-1) x)
        --      in ...
        -- In the initial iteration for f, f=Bot
        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
        -- places on its free variables.  Suppose it places none.  Then the
        --      x `fatbar` ...call to h...
        -- will give a x->V demand for x.  That turns into a L demand for x,
        -- which floats out of the defn for h.  Without the modifyEnv, that
        -- L demand doesn't get both'd with the Bot coming up from the inner
        -- call to f.  So we just get an L demand for x for g.
751

752
{-
753
Note [Do not strictify the argument dictionaries of a dfun]
754 755 756 757
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker can tie recursive knots involving dfuns, so we do the
conservative thing and refrain from strictifying a dfun's argument
dictionaries.
758
-}
759

760 761 762 763 764 765 766
setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
setBndrsDemandInfo (b:bs) (d:ds)
  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)
  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds
setBndrsDemandInfo [] ds = ASSERT( null ds ) []
setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)

767
annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
768 769 770 771
-- The returned env has the var deleted
-- The returned var is annotated with demand info
-- according to the result demand of the provided demand type
-- No effect on the argument demands
772
annotateBndr env dmd_ty var
773 774
  | isId var  = (dmd_ty', setIdDemandInfo var dmd)
  | otherwise = (dmd_ty, var)
775
  where
776
    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
777 778 779

annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
780 781
  where
    annotate dmd_ty bndr
782
      | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr
783 784 785
      | otherwise = (dmd_ty, bndr)

annotateLamIdBndr :: AnalEnv
786
                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
787
                  -> DmdType    -- Demand type of body
788 789 790
                  -> Id         -- Lambda binder
                  -> (DmdType,  -- Demand type of lambda
                      Id)       -- and binder annotated with demand
791

792
annotateLamIdBndr env arg_of_dfun dmd_ty id
793 794 795
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
  = ASSERT( isId id )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
796
    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
797
    (final_ty, setIdDemandInfo id dmd)
798 799 800 801 802 803
  where
      -- Watch out!  See note [Lambda-bound unfoldings]
    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
                 Nothing  -> main_ty
                 Just unf -> main_ty `bothDmdType` unf_ty
                          where
804
                             (unf_ty, _) = dmdAnalStar env dmd unf
805

806
    main_ty = addDemand dmd dmd_ty'
807
    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
808

809 810 811
deleteFVs :: DmdType -> [Var] -> DmdType
deleteFVs (DmdType fvs dmds res) bndrs
  = DmdType (delVarEnvList fvs bndrs) dmds res
812

813
{-
814 815 816 817 818 819 820 821 822 823 824 825 826 827
Note [CPR for sum types]
~~~~~~~~~~~~~~~~~~~~~~~~
At the moment we do not do CPR for let-bindings that
   * non-top level
   * bind a sum type
Reason: I found that in some benchmarks we were losing let-no-escapes,
which messed it all up.  Example
   let j = \x. ....
   in case y of
        True  -> j False
        False -> j True
If we w/w this we get
   let j' = \x. ....
   in case y of
828 829
        True  -> case j' False of { (# a #) -> Just a }
        False -> case j' True of { (# a #) -> Just a }
830 831 832 833
Notice that j' is not a let-no-escape any more.

However this means in turn that the *enclosing* function
may be CPR'd (via the returned Justs).  But in the case of
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
834
sums, there may be Nothing alternatives; and that messes
835 836 837 838 839
up the sum-type CPR.

Conclusion: only do this for products.  It's still not
guaranteed OK for products, but sums definitely lose sometimes.

840 841
Note [CPR for thunks]
~~~~~~~~~~~~~~~~~~~~~
842
If the rhs is a thunk, we usually forget the CPR info, because
843
it is presumably shared (else it would have been inlined, and
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
844 845
so we'd lose sharing if w/w'd it into a function).  E.g.

846 847 848
        let r = case expensive of
                  (a,b) -> (b,a)
        in ...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
849 850 851

If we marked r as having the CPR property, then we'd w/w into

852 853 854 855 856
        let $wr = \() -> case expensive of
                            (a,b) -> (# b, a #)
            r = case $wr () of
                  (# b,a #) -> (b,a)
        in ...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
857 858

But now r is a thunk, which won't be inlined, so we are no further ahead.
859
But consider
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
860

861 862
        f x = let r = case expensive of (a,b) -> (b,a)
              in if foo r then r else (x,x)
863 864

Does f have the CPR property?  Well, no.
865

866
However, if the strictness analyser has figured out (in a previous
867
iteration) that it's strict, then we DON'T need to forget the CPR info.
868
Instead we can retain the CPR info and do the thunk-splitting transform
869 870 871
(see WorkWrap.splitThunk).

This made a big difference to PrelBase.modInt, which had something like
872 873
        modInt = \ x -> let r = ... -> I# v in
                        ...body strict in r...
874 875 876
r's RHS isn't a value yet; but modInt returns r in various branches, so
if r doesn't have the CPR property then neither does modInt
Another case I found in practice (in Complex.magnitude), looks like this:
877 878
                let k = if ... then I# a else I# b
                in ... body strict in k ....
879
(For this example, it doesn't matter whether k is returned as part of
880
the overall result; but it does matter that k's RHS has the CPR property.)
881
Left to itself, the simplifier will make a join point thus:
882 883
                let $j k = ...body strict in k...
                if ... then $j (I# a) else $j (I# b)
884
With thunk-splitting, we get instead
885 886
                let $j x = let k = I#x in ...body strict in k...
                in if ... then $j a else $j b
887 888 889 890 891
This is much better; there's a good chance the I# won't get allocated.

The difficulty with this is that we need the strictness type to
look at the body... but we now need the body to calculate the demand
on the variable, so we can decide whether its strictness type should
892 893 894 895 896 897
have a CPR in it or not.  Simple solution:
        a) use strictness info from the previous iteration
        b) make sure we do at least 2 iterations, by doing a second
           round for top-level non-recs.  Top level recs will get at
           least 2 iterations except for totally-bottom functions
           which aren't very interesting anyway.
898 899 900

NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.

901
Note [Optimistic CPR in the "virgin" case]
902
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
903 904 905 906
Demand and strictness info are initialized by top elements. However,
this prevents from inferring a CPR property in the first pass of the
analyser, so we keep an explicit flag ae_virgin in the AnalEnv
datatype.
907

908
We can't start with 'not-demanded' (i.e., top) because then consider
909 910 911 912
        f x = let
                  t = ... I# x
              in
              if ... then t else I# y else f x'
913 914 915

In the first iteration we'd have no demand info for x, so assume
not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
916
we'd see that t was demanded, and so give it the CPR property, but by
917 918 919
now f has TopRes, so it will stay TopRes.  Instead, by checking the
ae_virgin flag at the first time round, we say 'yes t is demanded' the
first time.
920 921 922 923 924 925

However, this does mean that for non-recursive bindings we must
iterate twice to be sure of not getting over-optimistic CPR info,
in the case where t turns out to be not-demanded.  This is handled
by dmdAnalTopBind.

926

927 928 929
Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The strictness analyser used to have a HACK which ensured that NOINLNE
930 931
things were not strictness-analysed.  The reason was unsafePerformIO.
Left to itself, the strictness analyser would discover this strictness
932
for unsafePerformIO:
933
        unsafePerformIO:  C(U(AV))
934
But then consider this sub-expression
935 936 937
        unsafePerformIO (\s -> let r = f x in
                               case writeIORef v r s of (# s1, _ #) ->
                               (# s1, r #)
938 939 940 941 942 943 944
The strictness analyser will now find that r is sure to be eval'd,
and may then hoist it out.  This makes tests/lib/should_run/memo002
deadlock.

Solving this by making all NOINLINE things have no strictness info is overkill.
In particular, it's overkill for runST, which is perfectly respectable.
Consider
945
        f x = runST (return x)
946 947 948 949
This should be strict in x.

So the new plan is to define unsafePerformIO using the 'lazy' combinator:

950
        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
951

952
Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
953 954 955 956 957 958 959 960 961 962
magically NON-STRICT, and is inlined after strictness analysis.  So
unsafePerformIO will look non-strict, and that's what we want.

Now we don't need the hack in the strictness analyser.  HOWEVER, this
decision does mean that even a NOINLINE function is not entirely
opaque: some aspect of its implementation leaks out, notably its
strictness.  For example, if you have a function implemented by an
error stub, but which has RULES, you may want it not to be eliminated
in favour of error!

963
Note [Lazy and unleasheable free variables]
964
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
965
We put the strict and once-used FVs in the DmdType of the Id, so
966 967 968
that at its call sites we unleash demands on its strict fvs.
An example is 'roll' in imaginary/wheel-sieve2
Something like this:
969 970 971 972
        roll x = letrec
                     go y = if ... then roll (x-1) else x+1
                 in
                 go ms
973 974
We want to see that roll is strict in x, which is because
go is called.   So we put the DmdEnv for x in go's DmdType.
975

Simon Peyton Jones's avatar