DmdAnal.hs 63.3 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 #-}
11

12
module DmdAnal ( dmdAnalProgram ) where
13 14 15

#include "HsVersions.h"

16 17
import GhcPrelude

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

43 44 45
{-
************************************************************************
*                                                                      *
46
\subsection{Top level stuff}
47 48 49
*                                                                      *
************************************************************************
-}
50

51 52
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram dflags fam_envs binds
53
  = do {
54
        let { binds_plus_dmds = do_prog binds } ;
55 56
        dumpIfSet_dyn dflags Opt_D_dump_str_signatures
                      "Strictness signatures" $
57
            dumpStrSig binds_plus_dmds ;
58 59
        -- See Note [Stamp out space leaks in demand analysis]
        seqBinds binds_plus_dmds `seq` return binds_plus_dmds
60 61
    }
  where
62
    do_prog :: CoreProgram -> CoreProgram
63
    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds
64

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

79 80
dmdAnalTopBind env (Rec pairs)
  = (env', Rec pairs')
81
  where
82
    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs
83 84
                -- We get two iterations automatically
                -- c.f. the NonRec case above
85

86 87 88 89 90 91 92 93 94
{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The demand analysis pass outputs a new copy of the Core program in
which binders have been annotated with demand and strictness
information. It's tiresome to ensure that this information is fully
evaluated everywhere that we produce it, so we just run a single
seqBinds over the output before returning it, to ensure that there are
no references holding on to the input Core program.

95
This makes a ~30% reduction in peak memory usage when compiling
96
DynFlags (cf #9675 and #13426).
97

98 99 100 101 102 103 104 105 106
This is particularly important when we are doing late demand analysis,
since we don't do a seqBinds at any point thereafter. Hence code
generation would hold on to an extra copy of the Core program, via
unforced thunks in demand or strictness information; and it is the
most memory-intensive part of the compilation process, so this added
seqBinds makes a big difference in peak memory usage.
-}


107 108 109
{-
************************************************************************
*                                                                      *
110
\subsection{The analyser itself}
111 112
*                                                                      *
************************************************************************
113

114 115 116
Note [Ensure demand is strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important not to analyse e with a lazy demand because
117 118 119 120
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
121
b) More important, consider
122
        f (let x = R in x+x), where f is lazy
123 124 125 126 127 128
   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!
129
-}
130

131 132 133 134 135 136
-- 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
137 138 139

-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
140
-- See ↦* relation in the Cardinality Analysis paper
141 142
dmdAnalStar :: AnalEnv
            -> Demand   -- This one takes a *Demand*
143 144
            -> CoreExpr -- Should obey the let/app invariatn
            -> (BothDmdArg, CoreExpr)
145
dmdAnalStar env dmd e
146 147 148 149 150 151
  | (dmd_shell, cd) <- toCleanDmd dmd
  , (dmd_ty, e')    <- dmdAnal env cd e
  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
    -- The argument 'e' should satisfy the let/app invariant
    -- See Note [Analysing with absent demand] in Demand.hs
    (postProcessDmdType dmd_shell dmd_ty, e')
152 153

-- Main Demand Analsysis machinery
154
dmdAnal, dmdAnal' :: AnalEnv
155
        -> CleanDemand         -- The main one takes a *CleanDemand*
156 157 158 159 160
        -> CoreExpr -> (DmdType, CoreExpr)

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

161 162
dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                  dmdAnal' env d e
163

164
dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
165
dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
166 167
dmdAnal' _ _ (Coercion co)
  = (unitDmdType (coercionDmdEnv co), Coercion co)
168 169

dmdAnal' env dmd (Var var)
170
  = (dmdTransform env var dmd, Var var)
171

172
dmdAnal' env dmd (Cast e co)
173
  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
174
  where
175 176
    (dmd_ty, e') = dmdAnal env dmd e

177
dmdAnal' env dmd (Tick t e)
178
  = (dmd_ty, Tick t e')
179
  where
180
    (dmd_ty, e') = dmdAnal env dmd e
181

182
dmdAnal' env dmd (App fun (Type ty))
183
  = (fun_ty, App fun' (Type ty))
184
  where
185
    (fun_ty, fun') = dmdAnal env dmd fun
186

187 188
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
189
dmdAnal' env dmd (App fun arg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
190 191
  = -- This case handles value arguments (type args handled above)
    -- Crucially, coercions /are/ handled here, because they are
192
    -- value arguments (#10288)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
193
    let
194
        call_dmd          = mkCallDmd dmd
195 196 197
        (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
198
    in
199 200 201 202 203 204 205 206 207
--    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')
208

209
dmdAnal' env dmd (Lam var body)
210
  | isTyVar var
211 212
  = let
        (body_ty, body') = dmdAnal env dmd body
213
    in
214
    (body_ty, Lam var body')
215

216
  | otherwise
217 218 219
  = let (body_dmd, defer_and_use) = peelCallDmd dmd
          -- body_dmd: a demand to analyze the body

220 221
        env'             = extendSigsWithLam env var
        (body_ty, body') = dmdAnal env' body_dmd body
222
        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var
223
    in
224
    (postProcessUnsat defer_and_use lam_ty, Lam var' body')
225

226
dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
227
  -- Only one alternative with a product constructor
228
  | let tycon = dataConTyCon dc
229
  , isJust (isDataProductTyCon_maybe tycon)
230
  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
231
  = let
232 233 234 235 236 237
        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
238 239
        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
                | otherwise                   = alt_ty2
240

241 242
        -- Compute demand on the scrutinee
        -- See Note [Demand on scrutinee of a product case]
243
        scrut_dmd          = mkProdDmd id_dmds
244
        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
245 246 247
        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty
        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd
        bndrs'             = setBndrsDemandInfo bndrs id_dmds
248
    in
249
--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
250 251
--                                   , text "dmd" <+> ppr dmd
--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
252
--                                   , text "id_dmds" <+> ppr id_dmds
253 254
--                                   , text "scrut_dmd" <+> ppr scrut_dmd
--                                   , text "scrut_ty" <+> ppr scrut_ty
255
--                                   , text "alt_ty" <+> ppr alt_ty2
256
--                                   , text "res_ty" <+> ppr res_ty ]) $
257
    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])
258

259
dmdAnal' env dmd (Case scrut case_bndr ty alts)
260
  = let      -- Case expression with multiple alternatives
261
        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
262 263
        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
264 265 266
                               -- 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
267
        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
268
    in
269 270
--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "scrut_ty" <+> ppr scrut_ty
271
--                                   , text "alt_tys" <+> ppr alt_tys
272 273 274
--                                   , text "alt_ty" <+> ppr alt_ty
--                                   , text "res_ty" <+> ppr res_ty ]) $
    (res_ty, Case scrut' case_bndr' ty alts')
275

276 277 278 279 280 281 282 283 284 285 286 287
-- 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)
288
  | useLetUp id
289 290 291 292 293 294 295 296 297
  = (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

298
dmdAnal' env dmd (Let (NonRec id rhs) body)
299
  = (body_ty2, Let (NonRec id2 rhs') body')
300
  where
301
    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs
302 303 304
    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
    (body_ty, body')     = dmdAnal env1 dmd body
    (body_ty1, id2)      = annotateBndr env body_ty id1
305
    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
306

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

320
dmdAnal' env dmd (Let (Rec pairs) body)
321
  = let
322
        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs
323
        (body_ty, body')        = dmdAnal env' dmd body
324
        body_ty1                = deleteFVs body_ty (map fst pairs)
325
        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
326
    in
327
    body_ty2 `seq`
328
    (body_ty2,  Let (Rec pairs') body')
329

330 331 332
io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
-- See Note [IO hack in the demand analyser]
io_hack_reqd scrut con bndrs
333
  | (bndr:_) <- bndrs
334
  , con == tupleDataCon Unboxed 2
335 336 337 338 339
  , idType bndr `eqType` realWorldStatePrimTy
  , (fun, _) <- collectArgs scrut
  = case fun of
      Var f -> not (isPrimOpId f)
      _     -> True
340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355
  | 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'))

356 357 358 359

{- Note [IO hack in the demand analyser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's a hack here for I/O operations.  Consider
360 361 362 363 364 365 366 367

     case foo x s of { (# s', r #) -> y }

Is this strict in 'y'? Often not! If foo x s performs some observable action
(including raising an exception with raiseIO#, modifying a mutable variable, or
even ending the program normally), then we must not force 'y' (which may fail
to terminate) until we have performed foo x s.

368 369 370 371 372 373 374
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

375
A more complete example (#148, #1592) where this shows up is:
376 377 378 379 380 381 382 383 384 385 386 387
     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
388
(on an MVar not an Int), and made a material difference.
389 390 391

So if the scrutinee is a primop call, we *don't* apply the
state hack:
Gabor Greif's avatar
Gabor Greif committed
392
  - If it is a simple, terminating one like getMaskingState,
393 394
    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
395
    the case alternatives are already discarded.
396 397 398 399 400 401
  - 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
402 403 404 405 406 407 408 409 410 411
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.
412

413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
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}

434
so the resulting demand on |y| is U1.
435 436 437 438 439

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:

440
f y c =
441
  let h x = y |seq| x
442
   in case of
443 444 445 446 447 448 449 450 451 452
        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|.

453

454 455
************************************************************************
*                                                                      *
456
                    Demand transformer
457 458 459
*                                                                      *
************************************************************************
-}
460

461 462 463 464 465 466
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
467

468
dmdTransform env var dmd
469
  | isDataConWorkId var                          -- Data constructor
470
  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
471

472 473 474 475
  | gopt Opt_DmdTxDictSel (ae_dflags env),
    Just _ <- isClassOpId_maybe var -- Dictionary component selector
  = dmdTransformDictSelSig (idStrictness var) dmd

476
  | isGlobalId var                               -- Imported function
477
  = let res = dmdTransformSig (idStrictness var) dmd in
478
--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
479
    res
480 481 482

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

488
  | otherwise                                    -- Local non-letrec-bound thing
489
  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
490

491 492 493
{-
************************************************************************
*                                                                      *
494
\subsection{Bindings}
495 496 497
*                                                                      *
************************************************************************
-}
498 499

-- Recursive bindings
500
dmdFix :: TopLevelFlag
501
       -> AnalEnv                            -- Does not include bindings for this binding
502
       -> CleanDemand
503
       -> [(Id,CoreExpr)]
504
       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
505

506
dmdFix top_lvl env let_dmd orig_pairs
507
  = loop 1 initial_pairs
508
  where
509 510 511 512 513 514 515 516 517 518 519
    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)
520
            -- Note [Lazy and unleashable free variables]
521 522 523 524 525 526 527 528 529 530 531
            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'
532
      where
533 534 535 536
        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')
537

538 539 540 541 542 543 544 545 546 547
    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
548 549 550
                -- 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
551

552 553
        my_downRhs (env, lazy_fv) (id,rhs)
          = ((env', lazy_fv'), (id', rhs'))
554
          where
555
            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs
556 557
            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
558

559

560 561 562 563 564 565 566 567 568 569 570 571
    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!)
572
   (see Note [Lazy and unleashable free variables])
573 574 575 576 577 578 579
 * 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")

-}
580 581 582 583 584 585 586 587 588 589 590 591 592 593

-- 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
594
           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
595 596
           -> AnalEnv -> CleanDemand
           -> 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 let_dmd id rhs
601
  = (lazy_fv, id', rhs')
602
  where
603 604 605 606 607 608 609 610 611 612 613 614 615 616 617
    rhs_arity      = idArity id
    rhs_dmd
      -- See Note [Demand analysis for join points]
      -- See Note [idArity for join points] in SimplUtils
      -- rhs_arity matches the join arity of the join point
      | isJoinId id
      = mkCallDmds rhs_arity let_dmd
      | otherwise
      -- NB: rhs_arity
      -- See Note [Demand signatures are computed for a threshold demand based on idArity]
      = mkRhsDmd env rhs_arity rhs
    (DmdType rhs_fv rhs_dmds rhs_res, rhs')
                   = dmdAnal env rhs_dmd rhs
    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res')
    id'            = set_idStrictness env id sig
618
        -- See Note [NOINLINE and strictness]
619 620 621 622


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

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

629 630 631
    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]
632

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

641 642 643 644 645 646 647 648 649 650 651 652 653 654
-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
-- unleashing on the given function's @rhs@, by creating a call demand of
-- @rhs_arity@ with a body demand appropriate for possible product types.
-- See Note [Product demands for function body].
-- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a
-- clean usage demand of @C1(C1(U(U,U)))@.
mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
mkRhsDmd env rhs_arity rhs =
  case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of
    Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))
    _                 -> mkCallDmds rhs_arity cleanEvalDmd

-- | If given the let-bound 'Id', 'useLetUp' determines whether we should
-- process the binding up (body before rhs) or down (rhs before body).
655
--
656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
-- We use LetDown if there is a chance to get a useful strictness signature to
-- unleash at call sites. LetDown is generally more precise than LetUp if we can
-- correctly guess how it will be used in the body, that is, for which incoming
-- demand the strictness signature should be computed, which allows us to
-- unleash higher-order demands on arguments at call sites. This is mostly the
-- case when
--
--   * The binding takes any arguments before performing meaningful work (cf.
--     'idArity'), in which case we are interested to see how it uses them.
--   * The binding is a join point, hence acting like a function, not a value.
--     As a big plus, we know *precisely* how it will be used in the body; since
--     it's always tail-called, we can directly unleash the incoming demand of
--     the let binding on its RHS when computing a strictness signature. See
--     [Demand analysis for join points].
--
-- Thus, if the binding is not a join point and its arity is 0, we have a thunk
-- and use LetUp, implying that we have no usable demand signature available
-- when we analyse the let body.
--
-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free
-- vars at most once, regardless of how many times it was forced in the body.
-- This makes a real difference wrt. usage demands. The other reason is being
-- able to unleash a more precise product demand on its RHS once we know how the
-- thunk was used in the let body.
--
-- Characteristic examples, always assuming a single evaluation:
--
--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that
--     the expression uses @y@ at most once.
--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that
--     @b@ is absent.
--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that
--     the expression uses @y@ strictly, because we have @f@'s demand signature
--     available at the call site.
--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>
--     LetDown. Compared to LetUp, we find out that the expression uses @y@
--     strictly, because we can unleash @exit@'s signature at each call site.
--   * For a more convincing example with join points, see Note [Demand analysis
--     for join points].
--
useLetUp :: Var -> Bool
useLetUp f = idArity f == 0 && not (isJoinId f)
698

699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716
{- Note [Demand analysis for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   g :: (Int,Int) -> Int
   g (p,q) = p+q

   f :: T -> Int -> Int
   f x p = g (join j y = (p,y)
              in case x of
                   A -> j 3
                   B -> j 4
                   C -> (p,7))

If j was a vanilla function definition, we'd analyse its body with
evalDmd, and think that it was lazy in p.  But for join points we can
do better!  We know that j's body will (if called at all) be evaluated
with the demand that consumes the entire join-binding, in this case
the argument demand from g.  Whizzo!  g evaluates both components of
717
its argument pair, so p will certainly be evaluated if j is called.
718 719 720 721

For f to be strict in p, we need /all/ paths to evaluate p; in this
case the C branch does so too, so we are fine.  So, as usual, we need
to transport demands on free variables to the call site(s).  Compare
722
Note [Lazy and unleashable free variables].
723

724
The implementation is easy.  When analysing a join point, we can
725 726 727
analyse its body with the demand from the entire join-binding (written
let_dmd here).

728
Another win for join points!  #13543.
729

730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 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 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852
Note [Demand signatures are computed for a threshold demand based on idArity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We compute demand signatures assuming idArity incoming arguments to approximate
behavior for when we have a call site with at least that many arguments. idArity
is /at least/ the number of manifest lambdas, but might be higher for PAPs and
trivial RHS (see Note [Demand analysis for trivial right-hand sides]).

Because idArity of a function varies independently of its cardinality properties
(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode
the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'
(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to
unleash a demand signature when the incoming number of arguments is less than
that. See Note [What are demand signatures?] for more details on soundness.

Why idArity arguments? Because that's a conservative estimate of how many
arguments we must feed a function before it does anything interesting with them.
Also it elegantly subsumes the trivial RHS and PAP case.

There might be functions for which we might want to analyse for more incoming
arguments than idArity. Example:

  f x =
    if expensive
      then \y -> ... y ...
      else \y -> ... y ...

We'd analyse `f` under a unary call demand C(S), corresponding to idArity
being 1. That's enough to look under the manifest lambda and find out how a
unary call would use `x`, but not enough to look into the lambdas in the if
branches.

On the other hand, if we analysed for call demand C(C(S)), we'd get useful
strictness info for `y` (and more precise info on `x`) and possibly CPR
information, but

  * We would no longer be able to unleash the signature at unary call sites
  * Performing the worker/wrapper split based on this information would be
    implicitly eta-expanding `f`, playing fast and loose with divergence and
    even being unsound in the presence of newtypes, so we refrain from doing so.
    Also see Note [Don't eta expand in w/w] in WorkWrap.

Since we only compute one signature, we do so for arity 1. Computing multiple
signatures for different arities (i.e., polyvariance) would be entirely
possible, if it weren't for the additional runtime and implementation
complexity.

Note [idArity varies independently of dmdTypeDepth]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound
identifier. But that means we would have to zap demand signatures every time we
reset or decrease arity. That's an unnecessary dependency, because

  * The demand signature captures a semantic property that is independent of
    what the binding's current arity is
  * idArity is analysis information itself, thus volatile
  * We already *have* dmdTypeDepth, wo why not just use it to encode the
    threshold for when to unleash the signature
    (cf. Note [Understanding DmdType and StrictSig] in Demand)

Consider the following expression, for example:

    (let go x y = `x` seq ... in go) |> co

`go` might have a strictness signature of `<S><L>`. The simplifier will identify
`go` as a nullary join point through `joinPointBinding_maybe` and float the
coercion into the binding, leading to an arity decrease:

    join go = (\x y -> `x` seq ...) |> co in go

With the CoreLint check, we would have to zap `go`'s perfectly viable strictness
signature.

Note [What are demand signatures?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Demand analysis interprets expressions in the abstract domain of demand
transformers. Given an incoming demand we put an expression under, its abstract
transformer gives us back a demand type denoting how other things (like
arguments and free vars) were used when the expression was evaluated.
Here's an example:

  f x y =
    if x + expensive
      then \z -> z + y * ...
      else \z -> z * ...

The abstract transformer (let's call it F_e) of the if expression (let's call it
e) would transform an incoming head demand <S,HU> into a demand type like
{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:

     Demand ---F_e---> DmdType
     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>

Let's assume that the demand transformers we compute for an expression are
correct wrt. to some concrete semantics for Core. How do demand signatures fit
in? They are strange beasts, given that they come with strict rules when to
it's sound to unleash them.

Fortunately, we can formalise the rules with Galois connections. Consider
f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of
the actual abstract transformer of f's RHS for arity 2. So, what happens is that
we abstract *once more* from the abstract domain we already are in, replacing
the incoming Demand by a simple lattice with two elements denoting incoming
arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom
element). Here's the diagram:

     A_2 -----f_f----> DmdType
      ^                   |
      | α               γ |
      |                   v
     Demand ---F_f---> DmdType

With
  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness
  α(_)         =  <2
  γ(ty)        =  ty
and F_f being the abstract transformer of f's RHS and f_f being the abstracted
abstract transformer computable from our demand signature simply by

  f_f(>=2) = {}<S,1*U><L,U>
  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>

where postProcessUnsat makes a proper top element out of the given demand type.

853 854
Note [Demand analysis for trivial right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
855
Consider
856
    foo = plusInt |> co
857 858
where plusInt is an arity-2 function with known strictness.  Clearly
we want plusInt's strictness to propagate to foo!  But because it has
859
no manifest lambdas, it won't do so automatically, and indeed 'co' might
860
have type (Int->Int->Int) ~ T.
861

862 863 864
Fortunately, CoreArity gives 'foo' arity 2, which is enough for LetDown to
forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
CoreArity)! A small example is the test case NewtypeArity.
865

866

867 868 869 870 871
Note [Product demands for function body]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This example comes from shootout/binary_trees:

    Main.check' = \ b z ds. case z of z' { I# ip ->
872 873 874 875 876 877 878 879 880 881 882
                                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   }   }   }
883 884 885

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,
886
the whole function gets the CPR property if we do.
887 888 889 890

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

891 892
************************************************************************
*                                                                      *
893
\subsection{Strictness signatures and types}
894 895 896
*                                                                      *
************************************************************************
-}
897

898 899 900 901
unitDmdType :: DmdEnv -> DmdType
unitDmdType dmd_env = DmdType dmd_env [] topRes

coercionDmdEnv :: Coercion -> DmdEnv
902
coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
903
                    -- The VarSet from coVarsOfCo is really a VarEnv Var
904 905 906 907 908 909

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
910
addLazyFVs dmd_ty lazy_fvs
911
  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
912
        -- Using bothDmdType (rather than just both'ing the envs)
913
        -- is vital.  Consider
914 915 916 917 918 919
        --      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
920
        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was
921 922 923 924 925 926 927 928 929 930 931 932 933 934
        --      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.
935

936
{-
937
Note [Do not strictify the argument dictionaries of a dfun]
938 939 940 941
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker can tie recursive knots involving dfuns, so we do the
conservative thing and refrain from strictifying a dfun's argument
dictionaries.
942
-}
943

944 945 946 947 948 949 950
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)

951
annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
952 953 954 955
-- 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
956
annotateBndr env dmd_ty var
957 958
  | isId var  = (dmd_ty', setIdDemandInfo var dmd)
  | otherwise = (dmd_ty, var)
959
  where
960
    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
961

962
annotateLamIdBndr :: AnalEnv
963
                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
964
                  -> DmdType    -- Demand type of body
965 966 967
                  -> Id         -- Lambda binder
                  -> (DmdType,  -- Demand type of lambda
                      Id)       -- and binder annotated with demand
968

969
annotateLamIdBndr env arg_of_dfun dmd_ty id
970 971 972
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
  = ASSERT( isId id )
973
    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
974
    (final_ty, setIdDemandInfo id dmd)
975 976 977 978 979 980
  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
981
                             (unf_ty, _) = dmdAnalStar env dmd unf
982

983
    main_ty = addDemand dmd dmd_ty'
984
    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
985

986 987 988
deleteFVs :: DmdType -> [Var] -> DmdType
deleteFVs (DmdType fvs dmds res) bndrs
  = DmdType (delVarEnvList fvs bndrs) dmds res
989

990
{-
991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004
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
1005 1006
        True  -> case j' False of { (# a #) -> Just a }
        False -> case j' True of { (# a #) -> Just a }
1007 1008 1009 1010
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
Krzysztof Gogolewski committed
1011
sums, there may be Nothing alternatives; and that messes
1012 1013 1014 1015 1016
up the sum-type CPR.

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

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

1023 1024 1025
        let r = case expensive of
                  (a,b) -> (b,a)
        in ...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1026 1027 1028

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

1029 1030 1031 1032 1033
        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
1034 1035

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

1038 1039
        f x = let r = case expensive of (a,b) -> (b,a)
              in if foo r then r else (x,x)
1040 1041

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

1043
However, if the strictness analyser has figured out (in a previous
1044
iteration) that it's strict, then we DON'T need to forget the CPR info.
1045
Instead we can retain the CPR info and do the thunk-splitting transform
1046 1047 1048
(see WorkWrap.splitThunk).

This made a big difference to PrelBase.modInt, which had something like
1049 1050
        modInt = \ x -> let r = ... -> I# v in
                        ...body strict in r...
1051 1052 1053
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:
1054 1055
                let k = if ... then I# a else I# b
                in ... body strict in k ....
1056
(For this example, it doesn't matter whether k is returned as part of
1057
the overall result; but it does matter that k's RHS has the CPR property.)
1058
Left to itself, the simplifier will make a join point thus:
1059 1060
                let $j k = ...body strict in k...
                if ... then $j (I# a) else $j (I# b)
1061
With thunk-splitting, we get instead
1062 1063
                let $j x = let k = I#x in ...body strict in k...
                in if ... then $j a else $j b
1064 1065 1066 1067 1068
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
1069 1070 1071 1072 1073 1074
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.
1075 1076 1077

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

1078
Note [Optimistic CPR in the "virgin" case]
1079
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1080 1081 1082 1083
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.
1084

1085
We can't start with 'not-demanded' (i.e., top) because then consider
1086 1087 1088 1089
        f x = let
                  t = ... I# x
              in
              if ... then t else I# y else f x'
1090 1091 1092

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
1093
we'd see that t was demanded, and so give it the CPR property, but by
1094 1095 1096
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.
1097 1098 1099 1100 1101 1102

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.

1103

1104 1105 1106
Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The strictness analyser used to have a HACK which ensured that NOINLNE
1107 1108
things were not strictness-analysed.  The reason was unsafePerformIO.
Left to itself, the strictness analyser would discover this strictness
1109
for unsafePerformIO:
1110
        unsafePerformIO:  C(U(AV))
1111
But then consider this sub-expression
1112 1113 1114
        unsafePerformIO (\s -> let r = f x in
                               case writeIORef v r s of (# s1, _ #) ->
                               (# s1, r #)
1115 1116 1117 1118 1119 1120 1121
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
1122
        f x = runST (return x)
1123 1124 1125 1126
This should be strict in x.

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

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

1129
Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
1130 1131 1132 1133 1134 1135 1136 1137 1138 1139
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!

1140
Note [Lazy and unleashable free variables]
1141
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1142
We put the strict and once-used FVs in the DmdType of the Id, so
1143 1144 1145
that at its call sites we unleash demands on its strict fvs.
An example is 'roll' in imaginary/wheel-sieve2
Something like this:
1146 1147 1148 1149
        roll x = letrec
                     go y = if ... then roll (x-1) else x+1
                 in
                 go ms
1150 1151
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.
1152

1153
Another example:
1154

1155 1156 1157 1158 1159 1160
        f :: Int -> Int -> Int
        f x y = let t = x+1
            h z = if z==0 then t else
                  if z==1 then x+1 else
                  x + h (z-1)
        in h y
1161

1162 1163
Calling h does indeed evaluate x, but we can only see
that if we unleash a demand on x at the call site for t.
1164

1165 1166
Incidentally, here's a place where lambda-lifting h would
lose the cigar --- we couldn't see the joint strictness in t/x
1167

1168
        ON THE OTHER HAND
1169

1170
We don't want to put *all* the fv's from the RHS into the
1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194
DmdType. Because

 * it makes the strictness signatures larger, and hence slows down fixpointing

and

 * it is useless information at the call site anyways:
   For lazy, used-many times fv's we will never get any better result than
   that, no matter how good the actual demand on the function at the call site
   is (unless it is always absent, but then the whole binder is useless).

Therefore we exclude lazy multiple-used fv's from the environment in the
DmdType.

But now the signature lies! (Missing variables are assumed to be absent.) To
make up for this, the code that analyses the binding keeps the demand on those
variable separate (usually called "lazy_fv") and adds it to the demand of the
whole binding later.

What if we decide _not_ to store a strictness signature for a binding at all, as
we do when aborting a fixed-point iteration? The we risk losing the information
that the strict variables are being used. In that case, we take all free variables
mentioned in the (unsound) strictness signature, conservatively approximate the
demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
1195 1196


1197
Note [Lambda-bound unfoldings]
1198 1199 1200 1201 1202 1203 1204 1205 1206
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We allow a lambda-bound variable to carry an unfolding, a facility that is used
exclusively for join points; see Note [Case binders and join points].  If so,
we must be careful to demand-analyse the RHS of the unfolding!  Example
   \x. \y{=Just x}. <body>
Then if <body> uses 'y', then transitively it uses 'x', and we must not
forget that fact, otherwise we might make 'x' absent when it isn't.


1207 1208
************************************************************************
*                                                                      *
1209
\subsection{Strictness signatures}
1210 1211 1212
*                                                                      *
************************************************************************
-}
1213

1214 1215 1216 1217 1218
type DFunFlag = Bool  -- indicates if the lambda being considered is in the
                      -- sequence of lambdas at the top of the RHS of a dfun
notArgOfDfun :: DFunFlag
notArgOfDfun = False

1219
data AnalEnv
1220 1221
  = AE { ae_dflags :: DynFlags
       , ae_sigs   :: SigEnv
1222
       , ae_virgin :: Bool    -- True on first iteration only
1223
                              -- See Note [Initialising strictness]
1224
       , ae_rec_tc :: RecTcChecker
1225
       , ae_fam_envs :: FamInstEnvs
1226
 }
1227

1228 1229 1230 1231 1232 1233
        -- We use the se_env to tell us whether to
        -- record info about a variable in the DmdEnv
        -- We do so if it's a LocalId, but not top-level
        --
        -- The DmdEnv gives the demand on the free vars of the function
        -- when it is given enough args to satisfy the strictness signature
1234

1235 1236 1237 1238
type SigEnv = VarEnv (StrictSig, TopLevelFlag)

instance Outputable AnalEnv where
  ppr (AE { ae_sigs = env, ae_virgin = virgin })
1239 1240 1241
    = text "AE" <+> braces (vcat
         [ text "ae_virgin =" <+> ppr virgin
         , text "ae_sigs =" <+> ppr env ])
1242

1243 1244 1245 1246 1247 1248 1249 1250
emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv dflags fam_envs
    = AE { ae_dflags = dflags
         , ae_sigs = emptySigEnv
         , ae_virgin = True
         , ae_rec_tc = initRecTc
         , ae_fam_envs = fam_envs
         }
1251

1252
emptySigEnv :: SigEnv
1253 1254
emptySigEnv = emptyVarEnv

1255 1256 1257 1258
-- | Extend an environment with the strictness IDs attached to the id
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
extendAnalEnvs top_lvl env vars
  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
1259

1260 1261 1262
extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
extendSigEnvs top_lvl sigs vars
  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]
1263 1264 1265 1266

extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
extendAnalEnv top_lvl env var sig
  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
1267 1268

extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
1269
extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
1270

1271 1272
lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
1273

1274 1275
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin env = env { ae_virgin = False }
1276

1277 1278 1279
extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
-- Extend the AnalEnv when we meet a lambda binder
extendSigsWithLam env id
1280
  | isId id
1281
  , isStrictDmd (idDemandInfo id) || ae_virgin env
1282
       -- See Note [Optimistic CPR in the "virgin" case]
1283
       -- See Note [Initial CPR for strict binders]
1284
  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
1285
  = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
1286

1287
  | otherwise
1288 1289
  = env

1290 1291 1292
extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
-- See Note [CPR in a product case alternative]
extendEnvForProdAlt env scrut case_bndr dc bndrs
1293
  = foldl' do_con_arg env1 ids_w_strs
1294 1295 1296 1297 1298 1299 1300 1301
  where
    env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig

    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc
    case_bndr_sig = cprProdSig (dataConRepArity dc)
    fam_envs      = ae_fam_envs env

    do_con_arg env (id, str)
1302 1303
       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str
       , ae_virgin env || (is_var_scrut && is_strict)  -- See Note [CPR in a product case alternative]
1304 1305 1306 1307 1308 1309 1310 1311 1312 1313
       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id
       = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
       | otherwise
       = env

    is_var_scrut = is_var scrut
    is_var (Cast e _) = is_var e
    is_var (Var v)    = isLocalId v
    is_var _          = False

1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325
findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
-- Return the demands on the Ids in the [Var]
findBndrsDmds env dmd_ty bndrs
  = go dmd_ty bndrs
  where
    go dmd_ty []  = (dmd_ty, [])
    go dmd_ty (b:bs)
      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs
                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b
                    in (dmd_ty2, dmd : dmds)
      | otherwise = go dmd_ty bs

1326
findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
1327
-- See Note [Trimming a demand to a type] in Demand.hs
1328 1329 1330
findBndrDmd env arg_of_dfun dmd_ty id
  = (dmd_ty', dmd')
  where
1331
    dmd' = killUsageDemand (ae_dflags env) $
1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349
           strictify $
           trimToType starting_dmd (findTypeShape fam_envs id_ty)

    (dmd_ty', starting_dmd) = peelFV dmd_ty id

    id_ty = idType id

    strictify dmd
      | gopt Opt_DictsStrict (ae_dflags env)
             -- We never want to strictify a recursive let. At the moment
             -- annotateBndr is only call for non-recursive lets; if that
             -- changes, we need a RecFlag parameter and another guard here.
      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]
      = strictifyDictDmd id_ty dmd
      | otherwise
      = dmd

    fam_envs = ae_fam_envs env
1350 1351 1352

set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
set_idStrictness env id sig
1353
  = setIdStrictness id (killUsageSig (ae_dflags env) sig)
1354 1355

dumpStrSig :: CoreProgram -> SDoc
1356
dumpStrSig binds = vcat (map printId ids)
1357
  where
1358 1359 1360 1361 1362
  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
  getIds (NonRec i _) = [ i ]
  getIds (Rec bs)     = map fst bs
  printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
             | otherwise       = empty
1363

1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382
{- Note [CPR in a product case alternative]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a case alternative for a product type, we want to give some of the
binders the CPR property.  Specifically

 * The case binder; inside the alternative, the case binder always has
   the CPR property, meaning that a case on it will successfully cancel.
   Example:
        f True  x = case x of y { I# x' -> if x' ==# 3
                                           then y
                                           else I# 8 }
        f False x = I# 3

   By giving 'y' the CPR property, we ensure that 'f' does too, so we get
        f b x = case fw b x of { r -> I# r }
        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
        fw False x = 3

   Of course there is the usual risk of re-boxing: we have 'x' available
1383
   boxed and unboxed, but we return the unboxed version for the wrapper to
1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396
   box.  If the wrapper doesn't cancel with its caller, we'll end up
   re-boxing something that we did have available in boxed form.

 * Any strict binders with product type, can use
   Note [Initial CPR for strict binders].  But we can go a little
   further. Consider

      data T = MkT !Int Int

      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))
                   | otherwise = x

   For $wf2 we are going to unbox the MkT *and*, since it is strict, the
1397 1398
   first argument of the MkT; see Note [Add demands for strict constructors]
   in WwLib. But then we don't want box it up again when returning it! We want
1399 1400
   'f2' to have the CPR property, so we give 'x' the CPR property.

1401
 * It's a bit delicate because if this case is scrutinising something other