DmdAnal.hs 51.7 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 GHC.Core.Op.DmdAnal ( dmdAnalProgram ) where
13 14 15

#include "HsVersions.h"

16 17
import GhcPrelude

Sylvain Henry's avatar
Sylvain Henry committed
18
import GHC.Driver.Session
19
import GHC.Core.Op.WorkWrap.Lib ( findTypeShape )
20
import Demand   -- All of it
Sylvain Henry's avatar
Sylvain Henry committed
21 22
import GHC.Core
import GHC.Core.Seq     ( seqBinds )
23
import Outputable
24
import VarEnv
25
import BasicTypes
26
import Data.List        ( mapAccumL )
Sylvain Henry's avatar
Sylvain Henry committed
27
import GHC.Core.DataCon
28
import Id
29
import IdInfo
Sylvain Henry's avatar
Sylvain Henry committed
30
import GHC.Core.Utils
Sylvain Henry's avatar
Sylvain Henry committed
31 32 33 34
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion ( Coercion, coVarsOfCo )
import GHC.Core.FamInstEnv
35
import Util
36
import Maybes           ( isJust )
37
import TysWiredIn
38
import TysPrim          ( realWorldStatePrimTy )
Sylvain Henry's avatar
Sylvain Henry committed
39
import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )
David Feuer's avatar
David Feuer committed
40
import UniqSet
41

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

50
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
51 52 53 54 55 56 57
dmdAnalProgram dflags fam_envs binds = do
  let env             = emptyAnalEnv dflags fam_envs
  let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds
  dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $
    dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds
  -- See Note [Stamp out space leaks in demand analysis]
  seqBinds binds_plus_dmds `seq` return binds_plus_dmds
58

59
-- Analyse a (group of) top-level binding(s)
60
dmdAnalTopBind :: AnalEnv
61 62
               -> CoreBind
               -> (AnalEnv, CoreBind)
63
dmdAnalTopBind env (NonRec id rhs)
64
  = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')
65
  where
66
    ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs
67

68 69
dmdAnalTopBind env (Rec pairs)
  = (env', Rec pairs')
70
  where
71
    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs
72 73
                -- We get two iterations automatically
                -- c.f. the NonRec case above
74

75 76 77 78 79 80 81 82 83
{- 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.

84
This makes a ~30% reduction in peak memory usage when compiling
85
DynFlags (cf #9675 and #13426).
86

87 88 89 90 91 92 93 94 95
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.
-}


96 97 98
{-
************************************************************************
*                                                                      *
99
\subsection{The analyser itself}
100 101
*                                                                      *
************************************************************************
102

103 104 105
Note [Ensure demand is strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important not to analyse e with a lazy demand because
106 107 108 109
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
110
b) More important, consider
111
        f (let x = R in x+x), where f is lazy
112 113 114 115 116 117
   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!
118
-}
119

120 121 122 123 124 125
-- 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
126 127 128

-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
129
-- See ↦* relation in the Cardinality Analysis paper
130 131
dmdAnalStar :: AnalEnv
            -> Demand   -- This one takes a *Demand*
132
            -> CoreExpr -- Should obey the let/app invariant
133
            -> (BothDmdArg, CoreExpr)
134
dmdAnalStar env dmd e
135 136 137 138 139 140
  | (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')
141 142

-- Main Demand Analsysis machinery
Simon Peyton Jones's avatar
Simon Peyton Jones committed
143
dmdAnal, dmdAnal' :: AnalEnv
144
        -> CleanDemand         -- The main one takes a *CleanDemand*
145 146 147 148 149
        -> 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
150 151
dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                  dmdAnal' env d e
152

Simon Peyton Jones's avatar
Simon Peyton Jones committed
153
dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
154
dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
155 156
dmdAnal' _ _ (Coercion co)
  = (unitDmdType (coercionDmdEnv co), Coercion co)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
157 158

dmdAnal' env dmd (Var var)
159
  = (dmdTransform env var dmd, Var var)
160

Simon Peyton Jones's avatar
Simon Peyton Jones committed
161
dmdAnal' env dmd (Cast e co)
162
  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
163
  where
164 165
    (dmd_ty, e') = dmdAnal env dmd e

Simon Peyton Jones's avatar
Simon Peyton Jones committed
166
dmdAnal' env dmd (Tick t e)
167
  = (dmd_ty, Tick t e')
168
  where
169
    (dmd_ty, e') = dmdAnal env dmd e
170

Simon Peyton Jones's avatar
Simon Peyton Jones committed
171
dmdAnal' env dmd (App fun (Type ty))
172
  = (fun_ty, App fun' (Type ty))
173
  where
174
    (fun_ty, fun') = dmdAnal env dmd fun
175

176 177
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
178
dmdAnal' env dmd (App fun arg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
179 180
  = -- This case handles value arguments (type args handled above)
    -- Crucially, coercions /are/ handled here, because they are
181
    -- value arguments (#10288)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
182
    let
183
        call_dmd          = mkCallDmd dmd
184 185 186
        (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
187
    in
188 189 190 191 192 193 194 195 196
--    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')
197

Simon Peyton Jones's avatar
Simon Peyton Jones committed
198
dmdAnal' env dmd (Lam var body)
199
  | isTyVar var
200 201
  = let
        (body_ty, body') = dmdAnal env dmd body
202
    in
203
    (body_ty, Lam var body')
204

205
  | otherwise
206 207 208
  = let (body_dmd, defer_and_use) = peelCallDmd dmd
          -- body_dmd: a demand to analyze the body

209
        (body_ty, body') = dmdAnal env body_dmd body
210
        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var
211
    in
212
    (postProcessUnsat defer_and_use lam_ty, Lam var' body')
213

214
dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
215
  -- Only one alternative with a product constructor
216
  | let tycon = dataConTyCon dc
217
  , isJust (isDataProductTyCon_maybe tycon)
218
  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
219
  = let
220
        env_alt                  = env { ae_rec_tc = rec_tc' }
221 222 223 224
        (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
225 226
        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
                | otherwise                   = alt_ty2
227

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
246
dmdAnal' env dmd (Case scrut case_bndr ty alts)
247
  = let      -- Case expression with multiple alternatives
248
        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
249 250
        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
251 252 253
                               -- 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
254
        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
255
    in
256 257
--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "scrut_ty" <+> ppr scrut_ty
258
--                                   , text "alt_tys" <+> ppr alt_tys
259 260 261
--                                   , text "alt_ty" <+> ppr alt_ty
--                                   , text "res_ty" <+> ppr res_ty ]) $
    (res_ty, Case scrut' case_bndr' ty alts')
262

263 264 265 266 267 268 269 270 271 272 273 274
-- 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)
275
  | useLetUp id
276 277 278 279 280 281 282 283 284
  = (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
285
dmdAnal' env dmd (Let (NonRec id rhs) body)
286
  = (body_ty2, Let (NonRec id2 rhs') body')
287
  where
288
    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs
289 290 291
    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
    (body_ty, body')     = dmdAnal env1 dmd body
    (body_ty1, id2)      = annotateBndr env body_ty id1
Gabor Greif's avatar
Gabor Greif committed
292
    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
293

294 295 296 297 298 299 300 301 302 303 304 305
        -- 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.
306

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

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

343 344 345 346

{- Note [IO hack in the demand analyser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's a hack here for I/O operations.  Consider
347 348 349 350 351 352 353 354

     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.

355 356 357 358 359 360 361
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

362
A more complete example (#148, #1592) where this shows up is:
363 364 365 366 367 368 369 370 371 372 373 374
     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
375
(on an MVar not an Int), and made a material difference.
376

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

Note [Demand on the scrutinee of a product case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
389 390 391 392 393 394 395 396 397 398
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.
399

400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420
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}

421
so the resulting demand on |y| is U1.
422 423 424 425 426

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:

427
f y c =
428
  let h x = y |seq| x
429
   in case of
430 431 432 433 434 435 436 437 438 439
        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|.

440

441 442
************************************************************************
*                                                                      *
443
                    Demand transformer
444 445 446
*                                                                      *
************************************************************************
-}
447

448 449 450 451 452 453
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
454

455
dmdTransform env var dmd
456
  | isDataConWorkId var                          -- Data constructor
457
  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
458

459 460 461 462
  | gopt Opt_DmdTxDictSel (ae_dflags env),
    Just _ <- isClassOpId_maybe var -- Dictionary component selector
  = dmdTransformDictSelSig (idStrictness var) dmd

463
  | isGlobalId var                               -- Imported function
464 465
  , let res = dmdTransformSig (idStrictness var) dmd
  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
466
    res
467 468 469

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

475
  | otherwise                                    -- Local non-letrec-bound thing
476
  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
477

478 479 480
{-
************************************************************************
*                                                                      *
481
\subsection{Bindings}
482 483 484
*                                                                      *
************************************************************************
-}
485 486

-- Recursive bindings
487
dmdFix :: TopLevelFlag
488
       -> AnalEnv                            -- Does not include bindings for this binding
489
       -> CleanDemand
490
       -> [(Id,CoreExpr)]
491
       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
492

493
dmdFix top_lvl env let_dmd orig_pairs
494
  = loop 1 initial_pairs
495
  where
496 497 498 499 500 501 502 503 504 505 506
    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)
Gabor Greif's avatar
Gabor Greif committed
507
            -- Note [Lazy and unleashable free variables]
508 509 510 511 512 513 514 515 516 517 518
            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'
519
      where
520 521 522 523
        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')
524

525 526 527 528 529 530 531 532 533 534
    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
535 536 537
                -- 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
538

539 540
        my_downRhs (env, lazy_fv) (id,rhs)
          = ((env', lazy_fv'), (id', rhs'))
541
          where
542
            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
543 544
            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
545

546

547 548 549 550 551 552 553 554 555 556 557 558
    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!)
Gabor Greif's avatar
Gabor Greif committed
559
   (see Note [Lazy and unleashable free variables])
560 561 562 563 564 565 566
 * 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")

-}
567 568 569 570 571 572 573 574 575 576 577 578 579

-- 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”.
580 581 582 583 584
dmdAnalRhsLetDown
  :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
  -> AnalEnv -> CleanDemand
  -> Id -> CoreExpr
  -> (DmdEnv, Id, CoreExpr)
585 586
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
587
dmdAnalRhsLetDown rec_flag env let_dmd id rhs
588
  = (lazy_fv, id', rhs')
589
  where
590 591 592
    rhs_arity      = idArity id
    rhs_dmd
      -- See Note [Demand analysis for join points]
Sylvain Henry's avatar
Sylvain Henry committed
593
      -- See Note [Invariants on join points] invariant 2b, in GHC.Core
594
      --     rhs_arity matches the join arity of the join point
595 596 597 598 599 600
      | 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
601
    (DmdType rhs_fv rhs_dmds rhs_div, rhs')
602
                   = dmdAnal env rhs_dmd rhs
603 604 605
    -- TODO: Won't the following line unnecessarily trim down arity for join
    --       points returning a lambda in a C(S) context?
    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
606
    id'            = setIdStrictness id sig
607
        -- See Note [NOINLINE and strictness]
608 609 610 611


    -- See Note [Aggregated demand for cardinality]
    rhs_fv1 = case rec_flag of
612
                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
613 614
                Nothing -> rhs_fv

615
    -- See Note [Lazy and unleashable free variables]
616
    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
lukemaurer's avatar
lukemaurer committed
617
    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
618

619 620 621 622 623 624 625 626 627 628 629 630 631 632
-- | @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).
633
--
634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675
-- 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)
676

677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
{- 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
Gabor Greif's avatar
Gabor Greif committed
695
its argument pair, so p will certainly be evaluated if j is called.
696 697 698 699

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
Gabor Greif's avatar
Gabor Greif committed
700
Note [Lazy and unleashable free variables].
701

Gabor Greif's avatar
Gabor Greif committed
702
The implementation is easy.  When analysing a join point, we can
703 704 705
analyse its body with the demand from the entire join-binding (written
let_dmd here).

706
Another win for join points!  #13543.
707

708 709 710 711 712 713 714 715 716 717 718 719 720 721 722
However, note that the strictness signature for a join point can
look a little puzzling.  E.g.

    (join j x = \y. error "urk")
    (in case v of              )
    (     A -> j 3             )  x
    (     B -> j 4             )
    (     C -> \y. blah        )

The entire thing is in a C(S) context, so j's strictness signature
will be    [A]b
meaning one absent argument, returns bottom.  That seems odd because
there's a \y inside.  But it's right because when consumed in a C(1)
context the RHS of the join point is indeed bottom.

723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761
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.
762
    Also see Note [Don't eta expand in w/w] in GHC.Core.Op.WorkWrap.
763 764 765 766 767 768 769 770

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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sylvain Henry's avatar
Sylvain Henry committed
771
We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound
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
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.

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

Sylvain Henry's avatar
Sylvain Henry committed
855
Fortunately, GHC.Core.Arity gives 'foo' arity 2, which is enough for LetDown to
856
forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
Sylvain Henry's avatar
Sylvain Henry committed
857
GHC.Core.Arity)! A small example is the test case NewtypeArity.
858

859

860 861 862 863 864
Note [Product demands for function body]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This example comes from shootout/binary_trees:

    Main.check' = \ b z ds. case z of z' { I# ip ->
865 866 867 868 869 870 871 872 873 874 875
                                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   }   }   }
876 877 878

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,
879
the whole function gets the CPR property if we do.
880 881 882 883

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

884 885
************************************************************************
*                                                                      *
886
\subsection{Strictness signatures and types}
887 888 889
*                                                                      *
************************************************************************
-}
890

891
unitDmdType :: DmdEnv -> DmdType
892
unitDmdType dmd_env = DmdType dmd_env [] topDiv
893 894

coercionDmdEnv :: Coercion -> DmdEnv
David Feuer's avatar
David Feuer committed
895
coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
896
                    -- The VarSet from coVarsOfCo is really a VarEnv Var
897 898 899 900 901 902

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

929
{-
930
Note [Do not strictify the argument dictionaries of a dfun]
931 932 933 934
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker can tie recursive knots involving dfuns, so we do the
conservative thing and refrain from strictifying a dfun's argument
dictionaries.
935
-}
936

937 938 939 940 941 942 943
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)

944
annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
945 946 947 948
-- 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
949
annotateBndr env dmd_ty var
950 951
  | isId var  = (dmd_ty', setIdDemandInfo var dmd)
  | otherwise = (dmd_ty, var)
952
  where
953
    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
954

955
annotateLamIdBndr :: AnalEnv
956
                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
957
                  -> DmdType    -- Demand type of body
958 959 960
                  -> Id         -- Lambda binder
                  -> (DmdType,  -- Demand type of lambda
                      Id)       -- and binder annotated with demand
961

962
annotateLamIdBndr env arg_of_dfun dmd_ty id
963 964 965
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
  = ASSERT( isId id )
966
    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
967
    (final_ty, setIdDemandInfo id dmd)
968 969 970 971 972 973
  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
974
                             (unf_ty, _) = dmdAnalStar env dmd unf
975

976
    main_ty = addDemand dmd dmd_ty'
977
    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
978

979 980 981
deleteFVs :: DmdType -> [Var] -> DmdType
deleteFVs (DmdType fvs dmds res) bndrs
  = DmdType (delVarEnvList fvs bndrs) dmds res
982

983
{-
984 985 986
Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The strictness analyser used to have a HACK which ensured that NOINLNE
987 988
things were not strictness-analysed.  The reason was unsafePerformIO.
Left to itself, the strictness analyser would discover this strictness
989
for unsafePerformIO:
990
        unsafePerformIO:  C(U(AV))
991
But then consider this sub-expression
992 993 994
        unsafePerformIO (\s -> let r = f x in
                               case writeIORef v r s of (# s1, _ #) ->
                               (# s1, r #)
995 996 997 998 999 1000 1001
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
1002
        f x = runST (return x)
1003 1004 1005 1006
This should be strict in x.

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

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

1009
Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
1010 1011 1012 1013 1014 1015 1016 1017 1018 1019
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!

Gabor Greif's avatar
Gabor Greif committed
1020
Note [Lazy and unleashable free variables]
1021
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1022
We put the strict and once-used FVs in the DmdType of the Id, so
1023 1024 1025
that at its call sites we unleash demands on its strict fvs.
An example is 'roll' in imaginary/wheel-sieve2
Something like this:
1026 1027 1028 1029
        roll x = letrec
                     go y = if ... then roll (x-1) else x+1
                 in
                 go ms
1030 1031
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.
1032

1033
Another example:
1034

1035 1036 1037 1038 1039 1040
        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
1041

1042 1043
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.
1044

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

1048
        ON THE OTHER HAND
1049

1050
We don't want to put *all* the fv's from the RHS into the
1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074
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".
1075 1076


1077
Note [Lambda-bound unfoldings]
1078 1079 1080 1081 1082 1083 1084 1085 1086
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.


1087 1088
************************************************************************
*                                                                      *
1089
\subsection{Strictness signatures}
1090 1091 1092
*                                                                      *
************************************************************************
-}
1093

1094 1095 1096 1097 1098
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

1099
data AnalEnv
1100 1101
  = AE { ae_dflags :: DynFlags
       , ae_sigs   :: SigEnv
1102
       , ae_virgin :: Bool    -- True on first iteration only
1103
                              -- See Note [Initialising strictness]
1104
       , ae_rec_tc :: RecTcChecker
1105
       , ae_fam_envs :: FamInstEnvs
1106
 }
1107

1108 1109 1110 1111 1112 1113
        -- 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
1114

1115 1116 1117 1118
type SigEnv = VarEnv (StrictSig, TopLevelFlag)

instance Outputable AnalEnv where
  ppr (AE { ae_sigs = env, ae_virgin = virgin })
1119 1120 1121
    = text "AE" <+> braces (vcat
         [ text "ae_virgin =" <+> ppr virgin
         , text "ae_sigs =" <+> ppr env ])
1122

1123 1124 1125 1126 1127 1128 1129 1130
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
         }
1131

1132
emptySigEnv :: SigEnv
1133 1134
emptySigEnv = emptyVarEnv

1135 1136 1137 1138
-- | 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 }
1139

1140 1141 1142
extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
extendSigEnvs top_lvl sigs vars
  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]
1143 1144 1145 1146

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

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

1151 1152
lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
1153

1154 1155
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin env = env { ae_virgin = False }
1156

1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168
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

1169
findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
1170
-- See Note [Trimming a demand to a type] in Demand.hs
1171 1172 1173
findBndrDmd env arg_of_dfun dmd_ty id
  = (dmd_ty', dmd')
  where
1174
    dmd' = strictify $
1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191
           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
1192

1193 1194
{- Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1195 1196 1197 1198
See section 9.2 (Finding fixpoints) of the paper.

Our basic plan is to initialise the strictness of each Id in a
recursive group to "bottom", and find a fixpoint from there.  However,
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1199
this group B might be inside an *enclosing* recursive group A, in
1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222
which case we'll do the entire fixpoint shebang on for each iteration
of A. This can be illustrated by the following example:

Example:

  f [] = []
  f (x:xs) = let g []     = f xs
                 g (y:ys) = y+1 : g ys
              in g (h x)

At each iteration of the fixpoint for f, the analyser has to find a
fixpoint for the enclosed function g. In the meantime, the demand
values for g at each iteration for f are *greater* than those we
encountered in the previous iteration for f. Therefore, we can begin
the fixpoint for g not with the bottom value but rather with the
result of the previous analysis. I.e., when beginning the fixpoint
process for g, we can start from the demand signature computed for g
previously and attached to the binding occurrence of g.

To speed things up, we initialise each iteration of A (the enclosing
one) from the result of the last one, which is neatly recorded in each
binder.  That way we make use of earlier iterations of the fixpoint
algorithm. (Cunning plan.)