SimplUtils.hs 78 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
{-
(c) The AQUA Project, Glasgow University, 1993-1998

4
\section[SimplUtils]{The simplifier utilities}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7
8
{-# LANGUAGE CPP #-}

9
module SimplUtils (
10
        -- Rebuilding
11
        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
12

13
14
15
16
        -- Inlining,
        preInlineUnconditionally, postInlineUnconditionally,
        activeUnfolding, activeRule,
        getUnfoldingInRuleMatch,
17
        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
18

19
        -- The continuation type
Austin Seipp's avatar
Austin Seipp committed
20
        SimplCont(..), DupFlag(..),
21
        isSimplified,
22
        contIsDupable, contResultType, contHoleType,
23
        contIsTrivial, contArgs,
24
        countValArgs, countArgs,
25
        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
26
        interestingCallContext,
27

28
        -- ArgInfo
29
30
31
        ArgInfo(..), ArgSpec(..), mkArgInfo,
        addValArgTo, addCastTo, addTyArgTo,
        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
32
33

        abstractFloats
34
35
    ) where

36
#include "HsVersions.h"
37

38
import SimplEnv
39
import CoreMonad        ( SimplifierMode(..), Tick(..) )
40
import DynFlags
41
import CoreSyn
42
import qualified CoreSubst
43
import PprCore
44
45
import CoreFVs
import CoreUtils
46
import CoreArity
47
import CoreUnfold
48
import Name
49
import Id
50
import Var
51
import Demand
52
import SimplMonad
53
import Type     hiding( substTy )
54
import Coercion hiding( substCo )
55
import DataCon          ( dataConWorkId )
56
import VarEnv
57
import VarSet
58
59
import BasicTypes
import Util
60
import MonadUtils
61
import Outputable
62
import FastString
63
import Pair
64

65
import Control.Monad    ( when )
66

Austin Seipp's avatar
Austin Seipp committed
67
68
69
{-
************************************************************************
*                                                                      *
70
                The SimplCont and DupFlag types
Austin Seipp's avatar
Austin Seipp committed
71
72
*                                                                      *
************************************************************************
73

74
A SimplCont allows the simplifier to traverse the expression in a
75
76
77
78
79
80
81
zipper-like fashion.  The SimplCont represents the rest of the expression,
"above" the point of interest.

You can also think of a SimplCont as an "evaluation context", using
that term in the way it is used for operational semantics. This is the
way I usually think of it, For example you'll often see a syntax for
evaluation context looking like
82
        C ::= []  |  C e   |  case C of alts  |  C `cast` co
83
84
85
86
87
That's the kind of thing we are doing here, and I use that syntax in
the comments.


Key points:
88
  * A SimplCont describes a *strict* context (just like
89
90
91
92
    evaluation contexts do).  E.g. Just [] is not a SimplCont

  * A SimplCont describes a context that *does not* bind
    any variables.  E.g. \x. [] is not a SimplCont
Austin Seipp's avatar
Austin Seipp committed
93
-}
94

95
96
data SimplCont
  = Stop                -- An empty context, or <hole>
97
        OutType         -- Type of the <hole>
98
        CallCtxt        -- Tells if there is something interesting about
99
100
101
102
103
                        --          the context, and hence the inliner
                        --          should be a bit keener (see interestingCallContext)
                        -- Specifically:
                        --     This is an argument of a function that has RULES
                        --     Inlining the call might allow the rule to fire
104
                        -- Never ValAppCxt (use ApplyToVal instead)
105
                        -- or CaseCtxt (use Select instead)
106

107
  | CastIt            -- <hole> `cast` co
108
109
110
111
        OutCoercion             -- The coercion simplified
                                -- Invariant: never an identity coercion
        SimplCont

112
113
114
115
116
117
118
119
120
121
122
  | ApplyToVal {        -- <hole> arg
        sc_dup  :: DupFlag,          -- See Note [DupFlag invariants]
        sc_arg  :: InExpr,           -- The argument,
        sc_env  :: StaticEnv,        --     and its static env
        sc_cont :: SimplCont }

  | ApplyToTy {         -- <hole> ty
        sc_arg_ty  :: OutType,     -- Argument type
        sc_hole_ty :: OutType,     -- Type of the function, presumably (forall a. blah)
                                   -- See Note [The hole type in ApplyToTy]
        sc_cont    :: SimplCont }
123

124
125
126
127
128
129
  | Select {           -- case <hole> of alts
        sc_dup  :: DupFlag,                 -- See Note [DupFlag invariants]
        sc_bndr :: InId,                    -- case binder
        sc_alts :: [InAlt],                 -- Alternatives
        sc_env  ::  StaticEnv,              --   and their static environment
        sc_cont :: SimplCont }
130

131
  -- The two strict forms have no DupFlag, because we never duplicate them
132
133
134
135
136
137
138
139
  | StrictBind                  -- (\x* \xs. e) <hole>
        InId [InBndr]           -- let x* = <hole> in e
        InExpr StaticEnv        --      is a special case
        SimplCont

  | StrictArg           -- f e1 ..en <hole>
        ArgInfo         -- Specifies f, e1..en, Whether f has rules, etc
                        --     plus strictness flags for *further* args
140
        CallCtxt        -- Whether *this* argument position is interesting
141
        SimplCont
142

143
  | TickIt
144
        (Tickish Id)    -- Tick tickish <hole>
145
146
        SimplCont

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
data DupFlag = NoDup       -- Unsimplified, might be big
             | Simplified  -- Simplified
             | OkToDup     -- Simplified and small

isSimplified :: DupFlag -> Bool
isSimplified NoDup = False
isSimplified _     = True       -- Invariant: the subst-env is empty

perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type
perhapsSubstTy dup env ty
  | isSimplified dup = ty
  | otherwise        = substTy env ty

{-
Note [DupFlag invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~
In both (ApplyToVal dup _ env k)
   and  (Select dup _ _ env k)
the following invariants hold

  (a) if dup = OkToDup, then continuation k is also ok-to-dup
  (b) if dup = OkToDup or Simplified, the subst-env is empty
      (and and hence no need to re-simplify)
-}

instance Outputable DupFlag where
  ppr OkToDup    = ptext (sLit "ok")
  ppr NoDup      = ptext (sLit "nodup")
  ppr Simplified = ptext (sLit "simpl")

instance Outputable SimplCont where
178
179
180
181
182
183
184
  ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty
  ppr (CastIt co cont  )    = (ptext (sLit "CastIt") <+> ppr co) $$ ppr cont
  ppr (TickIt t cont)       = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })
    = (ptext (sLit "ApplyToTy") <+> pprParendType ty) $$ ppr cont
  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
    = (ptext (sLit "ApplyToVal") <+> ppr dup <+> pprParendExpr arg)
185
186
187
                                        $$ ppr cont
  ppr (StrictBind b _ _ _ cont)       = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
  ppr (StrictArg ai _ cont)           = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
188
189
190
  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
    = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
       ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216


{- Note [The hole type in ApplyToTy]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The sc_hole_ty field of ApplyToTy records the type of the "hole" in the
continuation.  It is absolutely necessary to compute contHoleType, but it is
not used for anything else (and hence may not be evaluated).

Why is it necessary for contHoleType?  Consider the continuation
     ApplyToType Int (Stop Int)
corresponding to
     (<hole> @Int) :: Int
What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),
and there is no way to know which, so we must record it.

In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType
for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably
doesn't matter because we'll never compute them all.

************************************************************************
*                                                                      *
                ArgInfo and ArgSpec
*                                                                      *
************************************************************************
-}

217
data ArgInfo
218
  = ArgInfo {
219
        ai_fun   :: OutId,      -- The function
220
        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)
221
222
        ai_type  :: OutType,    -- Type of (f a1 ... an)

223
224
225
226
227
228
229
230
231
232
233
234
        ai_rules :: [CoreRule], -- Rules for this function

        ai_encl :: Bool,        -- Flag saying whether this function
                                -- or an enclosing one has rules (recursively)
                                --      True => be keener to inline in all args

        ai_strs :: [Bool],      -- Strictness of remaining arguments
                                --   Usually infinite, but if it is finite it guarantees
                                --   that the function diverges after being given
                                --   that number of args
        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline
                                --   Always infinite
235
    }
236

237
238
239
240
241
data ArgSpec
  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal
  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy
          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)
  | CastBy OutCoercion                -- Cast by this; c.f. CastIt
242
243

instance Outputable ArgSpec where
244
245
246
247
248
249
  ppr (ValArg e)                 = ptext (sLit "ValArg") <+> ppr e
  ppr (TyArg { as_arg_ty = ty }) = ptext (sLit "TyArg") <+> ppr ty
  ppr (CastBy c)                 = ptext (sLit "CastBy") <+> ppr c

addValArgTo :: ArgInfo -> OutExpr -> ArgInfo
addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai
250
                        , ai_type = applyTypeToArg (ai_type ai) arg }
251

252
253
addTyArgTo :: ArgInfo -> OutType -> ArgInfo
addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai
254
                          , ai_type = piResultTy poly_fun_ty arg_ty }
255
256
257
  where
    poly_fun_ty = ai_type ai
    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }
258

259
260
261
262
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo ai co = ai { ai_args = CastBy co : ai_args ai
                     , ai_type = pSnd (coercionKind co) }

263
264
265
266
267
268
269
270
271
272
273
274
275
276
argInfoAppArgs :: [ArgSpec] -> [OutExpr]
argInfoAppArgs []                              = []
argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast
argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as
argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as

pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
pushSimplifiedArgs _env []           k = k
pushSimplifiedArgs env  (arg : args) k
  = case arg of
      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }
      CastBy c -> CastIt c rest
277
  where
278
279
    rest = pushSimplifiedArgs env args k
           -- The env has an empty SubstEnv
280
281

argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
282
283
284
285
-- NB: the [ArgSpec] is reversed so that the first arg
-- in the list is the last one in the application
argInfoExpr fun rev_args
  = go rev_args
286
  where
287
288
289
290
    go []                              = Var fun
    go (ValArg a                 : as) = go as `App` a
    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty
    go (CastBy co                : as) = mkCast (go as) co
291

292

Austin Seipp's avatar
Austin Seipp committed
293
{-
294
295
296
297
298
************************************************************************
*                                                                      *
                Functions on SimplCont
*                                                                      *
************************************************************************
Austin Seipp's avatar
Austin Seipp committed
299
-}
300

301
302
mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty BoringCtxt
303

304
mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold
305
mkRhsStop ty = Stop ty RhsCtxt
306

307
308
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop ty cci = Stop ty cci
309

310
-------------------
Ian Lynagh's avatar
Ian Lynagh committed
311
312
313
314
315
contIsRhsOrArg :: SimplCont -> Bool
contIsRhsOrArg (Stop {})       = True
contIsRhsOrArg (StrictBind {}) = True
contIsRhsOrArg (StrictArg {})  = True
contIsRhsOrArg _               = False
316

317
318
319
320
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ RhsCtxt) = True
contIsRhs _                = False

321
-------------------
322
contIsDupable :: SimplCont -> Bool
323
324
325
contIsDupable (Stop {})                         = True
contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k
contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]
326
contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...
327
328
contIsDupable (CastIt _ k)                      = contIsDupable k
contIsDupable _                                 = False
329

330
-------------------
331
contIsTrivial :: SimplCont -> Bool
332
333
334
335
336
contIsTrivial (Stop {})                                         = True
contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k
contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k
contIsTrivial (CastIt _ k)                                      = contIsTrivial k
contIsTrivial _                                                 = False
337

338
-------------------
339
contResultType :: SimplCont -> OutType
340
341
342
343
contResultType (Stop ty _)                  = ty
contResultType (CastIt _ k)                 = contResultType k
contResultType (StrictBind _ _ _ _ k)       = contResultType k
contResultType (StrictArg _ _ k)            = contResultType k
344
contResultType (Select { sc_cont = k })     = contResultType k
345
346
347
348
349
350
351
352
353
354
355
356
357
358
contResultType (ApplyToTy  { sc_cont = k }) = contResultType k
contResultType (ApplyToVal { sc_cont = k }) = contResultType k
contResultType (TickIt _ k)                 = contResultType k

contHoleType :: SimplCont -> OutType
contHoleType (Stop ty _)                      = ty
contHoleType (TickIt _ k)                     = contHoleType k
contHoleType (CastIt co _)                    = pFst (coercionKind co)
contHoleType (StrictBind b _ _ se _)          = substTy se (idType b)
contHoleType (StrictArg ai _ _)               = funArgTy (ai_type ai)
contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]
contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })
  = mkFunTy (perhapsSubstTy dup se (exprType e))
            (contHoleType k)
359
360
contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
  = perhapsSubstTy d se (idType b)
361

362
-------------------
363
countValArgs :: SimplCont -> Int
364
365
366
367
368
-- Count value arguments excluding coercions
countValArgs (ApplyToVal { sc_arg = arg, sc_cont = cont })
  | Coercion {} <- arg = countValArgs cont
  | otherwise          = 1 + countValArgs cont
countValArgs _         = 0
369
370

countArgs :: SimplCont -> Int
371
372
373
374
-- Count all arguments, including types, coercions, and other values
countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont
countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont
countArgs _                               = 0
375

376
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
377
-- Summarises value args, discards type args and coercions
Austin Seipp's avatar
Austin Seipp committed
378
-- The returned continuation of the call is only used to
379
380
381
382
-- answer questions like "are you interesting?"
contArgs cont
  | lone cont = (True, [], cont)
  | otherwise = go [] cont
383
  where
384
385
386
387
    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold
    lone (ApplyToVal {}) = False
    lone (CastIt {})     = False
    lone _               = True
388

389
390
391
392
393
    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })
                                        = go (is_interesting arg se : args) k
    go args (ApplyToTy { sc_cont = k }) = go args k
    go args (CastIt _ k)                = go args k
    go args k                           = (False, reverse args, k)
394

395
    is_interesting arg se = interestingArg se arg
396
397
                   -- Do *not* use short-cutting substitution here
                   -- because we want to get as much IdInfo as possible
398

399

400
-------------------
401
mkArgInfo :: Id
402
403
404
405
          -> [CoreRule] -- Rules for function
          -> Int        -- Number of value args
          -> SimplCont  -- Context of the call
          -> ArgInfo
406

407
mkArgInfo fun rules n_val_args call_cont
408
  | n_val_args < idArity fun            -- Note [Unsaturated functions]
409
410
  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
            , ai_rules = rules, ai_encl = False
411
412
            , ai_strs = vanilla_stricts
            , ai_discs = vanilla_discounts }
413
  | otherwise
414
415
  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
            , ai_rules = rules
416
            , ai_encl = interestingArgContext rules call_cont
417
418
            , ai_strs  = add_type_str fun_ty arg_stricts
            , ai_discs = arg_discounts }
419
  where
420
421
    fun_ty = idType fun

422
423
424
    vanilla_discounts, arg_discounts :: [Int]
    vanilla_discounts = repeat 0
    arg_discounts = case idUnfolding fun of
425
426
427
                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}
                              -> discounts ++ vanilla_discounts
                        _     -> vanilla_discounts
428
429

    vanilla_stricts, arg_stricts :: [Bool]
430
431
    vanilla_stricts  = repeat False

432
    arg_stricts
433
      = case splitStrictSig (idStrictness fun) of
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
          (demands, result_info)
                | not (demands `lengthExceeds` n_val_args)
                ->      -- Enough args, use the strictness given.
                        -- For bottoming functions we used to pretend that the arg
                        -- is lazy, so that we don't treat the arg as an
                        -- interesting context.  This avoids substituting
                        -- top-level bindings for (say) strings into
                        -- calls to error.  But now we are more careful about
                        -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
                   if isBotRes result_info then
                        map isStrictDmd demands         -- Finite => result is bottom
                   else
                        map isStrictDmd demands ++ vanilla_stricts
               | otherwise
               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
                                <+> ppr n_val_args <+> ppr demands )
                   vanilla_stricts      -- Not enough args, or no strictness
451

452
453
454
455
    add_type_str :: Type -> [Bool] -> [Bool]
    -- If the function arg types are strict, record that in the 'strictness bits'
    -- No need to instantiate because unboxed types (which dominate the strict
    -- types) can't instantiate type variables.
456
    -- add_type_str is done repeatedly (for each call); might be better
457
458
    -- once-for-all in the function
    -- But beware primops/datacons with no strictness
Ian Lynagh's avatar
Ian Lynagh committed
459
    add_type_str _ [] = []
460
461
462
463
464
465
    add_type_str fun_ty strs            -- Look through foralls
        | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty       -- Includes coercions
        = add_type_str fun_ty' strs
    add_type_str fun_ty (str:strs)      -- Add strict-type info
        | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
        = (str || isStrictType arg_ty) : add_type_str fun_ty' strs
Ian Lynagh's avatar
Ian Lynagh committed
466
    add_type_str _ strs
467
        = strs
468

469
470
471
{- Note [Unsaturated functions]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (test eyeball/inline4)
472
473
        x = a:as
        y = f x
474
475
476
477
where f has arity 2.  Then we do not want to inline 'x', because
it'll just be floated out again.  Even if f has lots of discounts
on its first argument -- it must be saturated for these to kick in
-}
478

479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525

{-
************************************************************************
*                                                                      *
        Interesting arguments
*                                                                      *
************************************************************************

Note [Interesting call context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
any gain, such as in an argument position.  Hence, if the continuation
is interesting (eg. a case scrutinee, application etc.) then we
inline, otherwise we don't.

Previously some_benefit used to return True only if the variable was
applied to some value arguments.  This didn't work:

        let x = _coerce_ (T Int) Int (I# 3) in
        case _coerce_ Int (T Int) x of
                I# y -> ....

we want to inline x, but can't see that it's a constructor in a case
scrutinee position, and some_benefit is False.

Another example:

dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)

....  case dMonadST _@_ x0 of (a,b,c) -> ....

we'd really like to inline dMonadST here, but we *don't* want to
inline if the case expression is just

        case x of y { DEFAULT -> ... }

since we can just eliminate this case instead (x is in WHNF).  Similar
applies when x is bound to a lambda expression.  Hence
contIsInteresting looks for case expressions with just a single
default case.
-}

interestingCallContext :: SimplCont -> CallCtxt
-- See Note [Interesting call context]
interestingCallContext cont
  = interesting cont
  where
526
527
    interesting (Select {})     = CaseCtxt
    interesting (ApplyToVal {}) = ValAppCtxt
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
        -- Can happen if we have (f Int |> co) y
        -- If f has an INLINE prag we need to give it some
        -- motivation to inline. See Note [Cast then apply]
        -- in CoreUnfold
    interesting (StrictArg _ cci _)         = cci
    interesting (StrictBind {})             = BoringCtxt
    interesting (Stop _ cci)                = cci
    interesting (TickIt _ k)                = interesting k
    interesting (ApplyToTy { sc_cont = k }) = interesting k
    interesting (CastIt _ k)                = interesting k
        -- If this call is the arg of a strict function, the context
        -- is a bit interesting.  If we inline here, we may get useful
        -- evaluation information to avoid repeated evals: e.g.
        --      x + (y * z)
        -- Here the contIsInteresting makes the '*' keener to inline,
        -- which in turn exposes a constructor which makes the '+' inline.
        -- Assuming that +,* aren't small enough to inline regardless.
        --
        -- It's also very important to inline in a strict context for things
        -- like
        --              foldr k z (f x)
        -- Here, the context of (f x) is strict, and if f's unfolding is
        -- a build it's *great* to inline it here.  So we must ensure that
        -- the context for (f x) is not totally uninteresting.

553
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
554
555
556
-- If the argument has form (f x y), where x,y are boring,
-- and f is marked INLINE, then we don't want to inline f.
-- But if the context of the argument is
557
--      g (f x y)
558
559
-- where g has rules, then we *do* want to inline f, in case it
-- exposes a rule that might fire.  Similarly, if the context is
560
--      h (g (f x x))
561
562
563
-- where h has rules, then we do want to inline f; hence the
-- call_cont argument to interestingArgContext
--
564
-- The ai-rules flag makes this happen; if it's
565
-- set, the inliner gets just enough keener to inline f
566
567
568
569
570
-- regardless of how boring f's arguments are, if it's marked INLINE
--
-- The alternative would be to *always* inline an INLINE function,
-- regardless of how boring its context is; but that seems overkill
-- For example, it'd mean that wrapper functions were always inlined
571
572
573
--
-- The call_cont passed to interestingArgContext is the context of
-- the call itself, e.g. g <hole> in the example above
574
575
interestingArgContext rules call_cont
  = notNull rules || enclosing_fn_has_rules
576
  where
577
578
    enclosing_fn_has_rules = go call_cont

579
    go (Select {})         = False
580
581
    go (ApplyToVal {})     = False  -- Shouldn't really happen
    go (ApplyToTy  {})     = False  -- Ditto
582
    go (StrictArg _ cci _) = interesting cci
583
    go (StrictBind {})     = False      -- ??
584
    go (CastIt _ c)        = go c
585
    go (Stop _ cci)        = interesting cci
586
    go (TickIt _ c)        = go c
587

588
589
    interesting RuleArgCtxt = True
    interesting _           = False
590

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635

{- Note [Interesting arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An argument is interesting if it deserves a discount for unfoldings
with a discount in that argument position.  The idea is to avoid
unfolding a function that is applied only to variables that have no
unfolding (i.e. they are probably lambda bound): f x y z There is
little point in inlining f here.

Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But
we must look through lets, eg (let x = e in C a b), because the let will
float, exposing the value, if we inline.  That makes it different to
exprIsHNF.

Before 2009 we said it was interesting if the argument had *any* structure
at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see Trac #3016.

But we don't regard (f x y) as interesting, unless f is unsaturated.
If it's saturated and f hasn't inlined, then it's probably not going
to now!

Note [Conlike is interesting]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
        f d = ...((*) d x y)...
        ... f (df d')...
where df is con-like. Then we'd really like to inline 'f' so that the
rule for (*) (df d) can fire.  To do this
  a) we give a discount for being an argument of a class-op (eg (*) d)
  b) we say that a con-like argument (eg (df d)) is interesting
-}

interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
-- See Note [Interesting arguments]
interestingArg env e = go env 0 e
  where
    -- n is # value args to which the expression is applied
    go env n (Var v)
       | SimplEnv { seIdSubst = ids, seInScope = in_scope } <- env
       = case lookupVarEnv ids v of
           Nothing                     -> go_var n (refineFromInScope in_scope v)
           Just (DoneId v')            -> go_var n (refineFromInScope in_scope v')
           Just (DoneEx e)             -> go (zapSubstEnv env)             n e
           Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e

636
637
638
639
640
641
642
    go _   _ (Lit {})          = ValueArg
    go _   _ (Type _)          = TrivArg
    go _   _ (Coercion _)      = TrivArg
    go env n (App fn (Type _)) = go env n fn
    go env n (App fn _)        = go env (n+1) fn
    go env n (Tick _ a)        = go env n a
    go env n (Cast e _)        = go env n e
643
    go env n (Lam v e)
644
645
646
647
648
649
650
651
652
       | isTyVar v             = go env n e
       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv
       | otherwise             = ValueArg
    go _ _ (Case {})           = NonTrivArg
    go env n (Let b e)         = case go env' n e of
                                   ValueArg -> ValueArg
                                   _        -> NonTrivArg
                               where
                                 env' = env `addNewInScopeIds` bindersOf b
653
654
655
656
657
658
659
660
661
662
663
664

    go_var n v
       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that
                                        --    data constructors here
       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding
       | n > 0             = NonTrivArg -- Saturated or unknown call
       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding
                                        -- See Note [Conlike is interesting]
       | otherwise         = TrivArg    -- n==0, no useful unfolding
       where
         conlike_unfolding = isConLikeUnfolding (idUnfolding v)

Austin Seipp's avatar
Austin Seipp committed
665
666
667
{-
************************************************************************
*                                                                      *
668
                  SimplifierMode
Austin Seipp's avatar
Austin Seipp committed
669
670
*                                                                      *
************************************************************************
671

672
673
674
675
676
677
The SimplifierMode controls several switches; see its definition in
CoreMonad
        sm_rules      :: Bool     -- Whether RULES are enabled
        sm_inline     :: Bool     -- Whether inlining is enabled
        sm_case_case  :: Bool     -- Whether case-of-case is enabled
        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
Austin Seipp's avatar
Austin Seipp committed
678
-}
679

680
681
682
683
684
685
686
687
688
simplEnvForGHCi :: DynFlags -> SimplEnv
simplEnvForGHCi dflags
  = mkSimplEnv $ SimplMode { sm_names = ["GHCi"]
                           , sm_phase = InitialPhase
                           , sm_rules = rules_on
                           , sm_inline = False
                           , sm_eta_expand = eta_expand_on
                           , sm_case_case = True }
  where
ian@well-typed.com's avatar
ian@well-typed.com committed
689
690
    rules_on      = gopt Opt_EnableRewriteRules   dflags
    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
691
692
   -- Do not do any inlining, in case we expose some unboxed
   -- tuple stuff that confuses the bytecode interpreter
693

694
695
696
updModeForStableUnfoldings :: Activation -> SimplifierMode -> SimplifierMode
-- See Note [Simplifying inside stable unfoldings]
updModeForStableUnfoldings inline_rule_act current_mode
697
698
699
  = current_mode { sm_phase = phaseFromActivation inline_rule_act
                 , sm_inline = True
                 , sm_eta_expand = False }
700
                 -- For sm_rules, just inherit; sm_rules might be "off"
Gabor Greif's avatar
typos    
Gabor Greif committed
701
                 -- because of -fno-enable-rewrite-rules
702
703
704
  where
    phaseFromActivation (ActiveAfter n) = Phase n
    phaseFromActivation _               = InitialPhase
705

706
707
708
updModeForRules :: SimplifierMode -> SimplifierMode
-- See Note [Simplifying rules]
updModeForRules current_mode
709
710
711
712
713
  = current_mode { sm_phase  = InitialPhase
                 , sm_inline = False
                 , sm_rules  = False
                 , sm_eta_expand = False }

714
{- Note [Simplifying rules]
715
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
716
When simplifying a rule, refrain from any inlining or applying of other RULES.
717

718
719
Doing anything to the LHS is plain confusing, because it means that what the
rule matches is not what the user wrote. c.f. Trac #10595, and #10528.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
720
721
722
Moreover, inlining (or applying rules) on rule LHSs risks introducing
Ticks into the LHS, which makes matching trickier. Trac #10665, #10745.

723
724
Doing this to either side confounds tools like HERMIT, which seek to reason
about and apply the RULES as originally written. See Trac #10829.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
725

726
727
Note [Inlining in gentle mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
728
Something is inlined if
729
730
   (i)   the sm_inline flag is on, AND
   (ii)  the thing has an INLINE pragma, AND
731
   (iii) the thing is inlinable in the earliest phase.
732
733

Example of why (iii) is important:
734
735
  {-# INLINE [~1] g #-}
  g = ...
736

737
738
739
740
741
  {-# INLINE f #-}
  f x = g (g x)

If we were to inline g into f's inlining, then an importing module would
never be able to do
742
        f e --> g (g e) ---> RULE fires
743
because the stable unfolding for f has had g inlined into it.
744
745

On the other hand, it is bad not to do ANY inlining into an
746
stable unfolding, because then recursive knots in instance declarations
747
748
don't get unravelled.

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
749
750
751
However, *sometimes* SimplGently must do no call-site inlining at all
(hence sm_inline = False).  Before full laziness we must be careful
not to inline wrappers, because doing so inhibits floating
752
753
754
755
    e.g. ...(case f x of ...)...
    ==> ...(case (case x of I# x# -> fw x#) of ...)...
    ==> ...(case x of I# x# -> case fw x# of ...)...
and now the redex (f x) isn't floatable any more.
756

757
The no-inlining thing is also important for Template Haskell.  You might be
758
759
compiling in one-shot mode with -O2; but when TH compiles a splice before
running it, we don't want to use -O2.  Indeed, we don't want to inline
760
anything, because the byte-code interpreter might get confused about
761
unboxed tuples and suchlike.
762

763
764
765
Note [Simplifying inside stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must take care with simplification inside stable unfoldings (which come from
766
INLINE pragmas).
767

768
First, consider the following example
769
770
771
772
773
        let f = \pq -> BIG
        in
        let g = \y -> f y y
            {-# INLINE g #-}
        in ...g...g...g...g...g...
774
775
Now, if that's the ONLY occurrence of f, it might be inlined inside g,
and thence copied multiple times when g is inlined. HENCE we treat
776
any occurrence in a stable unfolding as a multiple occurrence, not a single
777
778
one; see OccurAnal.addRuleUsage.

779
780
781
Second, we do want *do* to some modest rules/inlining stuff in stable
unfoldings, partly to eliminate senseless crap, and partly to break
the recursive knots generated by instance declarations.
782
783

However, suppose we have
784
785
786
        {-# INLINE <act> f #-}
        f = <rhs>
meaning "inline f in phases p where activation <act>(p) holds".
787
Then what inlinings/rules can we apply to the copy of <rhs> captured in
788
f's stable unfolding?  Our model is that literally <rhs> is substituted for
789
f when it is inlined.  So our conservative plan (implemented by
790
updModeForStableUnfoldings) is this:
791
792

  -------------------------------------------------------------
793
794
  When simplifying the RHS of an stable unfolding, set the phase
  to the phase in which the stable unfolding first becomes active
795
796
797
798
  -------------------------------------------------------------

That ensures that

799
  a) Rules/inlinings that *cease* being active before p will
800
     not apply to the stable unfolding, consistent with it being
801
802
803
     inlined in its *original* form in phase p.

  b) Rules/inlinings that only become active *after* p will
804
     not apply to the stable unfolding, again to be consistent with
805
806
     inlining the *original* rhs in phase p.

807
808
809
For example,
        {-# INLINE f #-}
        f x = ...g...
810

811
812
        {-# NOINLINE [1] g #-}
        g y = ...
813

814
        {-# RULE h g = ... #-}
815
816
817
818
819
Here we must not inline g into f's RHS, even when we get to phase 0,
because when f is later inlined into some other module we want the
rule for h to fire.

Similarly, consider
820
821
        {-# INLINE f #-}
        f x = ...g...
822

823
        g y = ...
824
825
826
and suppose that there are auto-generated specialisations and a strictness
wrapper for g.  The specialisations get activation AlwaysActive, and the
strictness wrapper get activation (ActiveAfter 0).  So the strictness
827
wrepper fails the test and won't be inlined into f's stable unfolding. That
828
829
means f can inline, expose the specialised call to g, so the specialisation
rules can fire.
830

831
832
A note about wrappers
~~~~~~~~~~~~~~~~~~~~~
833
834
It's also important not to inline a worker back into a wrapper.
A wrapper looks like
835
        wraper = inline_me (\x -> ...worker... )
836
837
838
839
Normally, the inline_me prevents the worker getting inlined into
the wrapper (initially, the worker's only call site!).  But,
if the wrapper is sure to be called, the strictness analyser will
mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
840
continuation.
Austin Seipp's avatar
Austin Seipp committed
841
-}
842

843
activeUnfolding :: SimplEnv -> Id -> Bool
844
activeUnfolding env
845
846
847
848
849
850
  | not (sm_inline mode) = active_unfolding_minimal
  | otherwise            = case sm_phase mode of
                             InitialPhase -> active_unfolding_gentle
                             Phase n      -> active_unfolding n
  where
    mode = getMode env
851

852
getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
853
-- When matching in RULE, we want to "look through" an unfolding
854
855
-- (to see a constructor) if *rules* are on, even if *inlinings*
-- are not.  A notable example is DFuns, which really we want to
856
857
858
-- match in rules like (op dfun) in gentle mode. Another example
-- is 'otherwise' which we want exprIsConApp_maybe to be able to
-- see very early on
859
860
getUnfoldingInRuleMatch env
  = (in_scope, id_unf)
861
  where
862
    in_scope = seInScope env
863
    mode = getMode env
864
865
866
    id_unf id | unf_is_active id = idUnfolding id
              | otherwise        = NoUnfolding
    unf_is_active id
867
868
     | not (sm_rules mode) = active_unfolding_minimal id
     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
869

870
active_unfolding_minimal :: Id -> Bool
871
872
873
874
875
-- Compuslory unfoldings only
-- Ignore SimplGently, because we want to inline regardless;
-- the Id has no top-level binding at all
--
-- NB: we used to have a second exception, for data con wrappers.
876
-- On the grounds that we use gentle mode for rule LHSs, and
877
878
879
880
-- they match better when data con wrappers are inlined.
-- But that only really applies to the trivial wrappers (like (:)),
-- and they are now constructed as Compulsory unfoldings (in MkId)
-- so they'll happen anyway.
881
882
883
884
active_unfolding_minimal id = isCompulsoryUnfolding (realIdUnfolding id)

active_unfolding :: PhaseNum -> Id -> Bool
active_unfolding n id = isActiveIn n (idInlineActivation id)
885

886
active_unfolding_gentle :: Id -> Bool
887
888
889
-- Anything that is early-active
-- See Note [Gentle mode]
active_unfolding_gentle id
890
891
  =  isInlinePragma prag
  && isEarlyActive (inlinePragmaActivation prag)
892
893
       -- NB: wrappers are not early-active
  where
894
    prag = idInlinePragma id
895

896
----------------------
897
activeRule :: SimplEnv -> Activation -> Bool
898
-- Nothing => No rules at all
899
900
901
activeRule env
  | not (sm_rules mode) = \_ -> False     -- Rewriting is off
  | otherwise           = isActive (sm_phase mode)
902
903
  where
    mode = getMode env
904

Austin Seipp's avatar
Austin Seipp committed
905
906
907
{-
************************************************************************
*                                                                      *
908
                  preInlineUnconditionally
Austin Seipp's avatar
Austin Seipp committed
909
910
*                                                                      *
************************************************************************
911
912
913
914
915
916
917
918
919
920
921
922
923

preInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~
@preInlineUnconditionally@ examines a bndr to see if it is used just
once in a completely safe way, so that it is safe to discard the
binding inline its RHS at the (unique) usage site, REGARDLESS of how
big the RHS might be.  If this is the case we don't simplify the RHS
first, but just inline it un-simplified.

This is much better than first simplifying a perhaps-huge RHS and then
inlining and re-simplifying it.  Indeed, it can be at least quadratically
better.  Consider

924
925
926
927
928
        x1 = e1
        x2 = e2[x1]
        x3 = e3[x2]
        ...etc...
        xN = eN[xN-1]
929
930

We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
931
932
This can happen with cascades of functions too:

933
934
935
936
        f1 = \x1.e1
        f2 = \xs.e2[f1]
        f3 = \xs.e3[f3]
        ...etc...
937
938
939

THE MAIN INVARIANT is this:

940
        ----  preInlineUnconditionally invariant -----
941
942
   IF preInlineUnconditionally chooses to inline x = <rhs>
   THEN doing the inlining should not change the occurrence
943
944
        info for the free vars of <rhs>
        ----------------------------------------------
945
946

For example, it's tempting to look at trivial binding like
947
        x = y
948
949
950
951
and inline it unconditionally.  But suppose x is used many times,
but this is the unique occurrence of y.  Then inlining x would change
y's occurrence info, which breaks the invariant.  It matters: y
might have a BIG rhs, which will now be dup'd at every occurrenc of x.
952
953


954
Even RHSs labelled InlineMe aren't caught here, because there might be
955
956
957
958
no benefit from inlining at the call site.

[Sept 01] Don't unconditionally inline a top-level thing, because that
can simply make a static thing into something built dynamically.  E.g.
959
960
        x = (a,b)
        main = \s -> h x
961
962
963
964
965
966
967
968
969
970
971
972
973
974

[Remember that we treat \s as a one-shot lambda.]  No point in
inlining x unless there is something interesting about the call site.

But watch out: if you aren't careful, some useful foldr/build fusion
can be lost (most notably in spectral/hartel/parstof) because the
foldr didn't see the build.  Doing the dynamic allocation isn't a big
deal, in fact, but losing the fusion can be.  But the right thing here
seems to be to do a callSiteInline based on the fact that there is
something interesting about the call site (it's strict).  Hmm.  That
seems a bit fragile.

Conclusion: inline top level things gaily until Phase 0 (the last
phase), at which point don't.
975

976
977
978
979
980
981
982
983
984
985
986
987
Note [pre/postInlineUnconditionally in gentle mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Even in gentle mode we want to do preInlineUnconditionally.  The
reason is that too little clean-up happens if you don't inline
use-once things.  Also a bit of inlining is *good* for full laziness;
it can expose constant sub-expressions.  Example in
spectral/mandel/Mandel.hs, where the mandelset function gets a useful
let-float if you inline windowToViewport

However, as usual for Gentle mode, do not inline things that are
inactive in the intial stages.  See Note [Gentle mode].

988
Note [Stable unfoldings and preInlineUnconditionally]
989
990
991
992
993
994
995
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
Example

   {-# INLINE f #-}
   f :: Eq a => a -> a
   f x = ...
996

997
998
999
1000
1001
   fInt :: Int -> Int
   fInt = f Int dEqInt

   ...fInt...fInt...fInt...

Joachim Breitner's avatar
Joachim Breitner committed
1002
Here f occurs just once, in the RHS of fInt. But if we inline it there
1003
1004
1005
1006
we'll lose the opportunity to inline at each of fInt's call sites.
The INLINE pragma will only inline when the application is saturated
for exactly this reason; and we don't want PreInlineUnconditionally
to second-guess it.  A live example is Trac #3736.
1007
    c.f. Note [Stable unfoldings and postInlineUnconditionally]
1008

Joachim Breitner's avatar
Joachim Breitner committed
1009
Note [Top-level bottoming Ids]
1010
1011
1012
1013
1014
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Don't inline top-level Ids that are bottoming, even if they are used just
once, because FloatOut has gone to some trouble to extract them out.
Inlining them won't make the program run faster!

1015
1016
Note [Do not inline CoVars unconditionally]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1017
1018
1019
Coercion variables appear inside coercions, and the RHS of a let-binding
is a term (not a coercion) so we can't necessarily inline the latter in
the former.
Austin Seipp's avatar
Austin Seipp committed
1020
-}
1021

1022
preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
1023
1024
1025
1026
-- Precondition: rhs satisfies the let/app invariant
-- See Note [CoreSyn let/app invariant] in CoreSyn
-- Reason: we don't want to inline single uses, or discard dead bindings,
--         for unlifted, side-effect-full bindings
1027
preInlineUnconditionally dflags env top_lvl bndr rhs
1028
  | not active                               = False
1029
  | isStableUnfolding (idUnfolding bndr)     = False -- Note [Stable unfoldings and preInlineUnconditionally]
1030
  | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
ian@well-typed.com's avatar
ian@well-typed.com committed
1031
  | not (gopt Opt_SimplPreInlining dflags)   = False
1032
  | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
1033
  | otherwise = case idOccInfo bndr of
1034
1035
1036
                  IAmDead                    -> True -- Happens in ((\x.1) v)
                  OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
                  _                          -> False
1037
  where
1038
1039
1040
    mode = getMode env
    active = isActive (sm_phase mode) act
             -- See Note [pre/postInlineUnconditionally in gentle mode]
1041
    act = idInlineActivation bndr
1042
1043
1044
    try_once in_lam int_cxt     -- There's one textual occurrence
        | not in_lam = isNotTopLevel top_lvl || early_phase
        | otherwise  = int_cxt && canInlineInLam rhs
1045

1046
-- Be very careful before inlining inside a lambda, because (a) we must not
1047
-- invalidate occurrence information, and (b) we want to avoid pushing a
1048
-- single allocation (here) into multiple allocations (inside lambda).
1049
-- Inlining a *function* with a single *saturated* call would be ok, mind you.
1050
1051
1052
1053
1054
1055
1056
1057
1058
--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
--      where
--              is_cheap = exprIsCheap rhs
--              ok = is_cheap && int_cxt

        --      int_cxt         The context isn't totally boring
        -- E.g. let f = \ab.BIG in \y. map f xs
        --      Don't want to substitute for f, because then we allocate
        --      its closure every time the \y is called
1059
        -- But: let f = \ab.BIG in \y. map (f y) xs
1060
1061
1062
1063
1064
1065
1066
        --      Now we do want to substitute for f, even though it's not
        --      saturated, because we're going to allocate a closure for
        --      (f y) every time round the loop anyhow.

        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
        -- so substituting rhs inside a lambda doesn't change the occ info.
        -- Sadly, not quite the same as exprIsHNF.
Peter Wortmann's avatar
Peter Wortmann committed
1067
1068
1069
1070
    canInlineInLam (Lit _)    = True
    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e
    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e
    canInlineInLam _          = False
1071
1072
      -- not ticks.  Counting ticks cannot be duplicated, and non-counting
      -- ticks around a Lam will disappear anyway.
1073

1074
1075
1076
    early_phase = case sm_phase mode of
                    Phase 0 -> False
                    _       -> True
1077
-- If we don't have this early_phase test, consider
1078
--      x = length [1,2,3]
1079
1080
1081
-- The full laziness pass carefully floats all the cons cells to
-- top level, and preInlineUnconditionally floats them all back in.
-- Result is (a) static allocation replaced by dynamic allocation
1082
1083
1084
--           (b) many simplifier iterations because this tickles
--               a related problem; only one inlining per pass
--
1085
1086
1087
1088
1089
-- On the other hand, I have seen cases where top-level fusion is
-- lost if we don't inline top level thing (e.g. string constants)
-- Hence the test for phase zero (which is the phase for all the final
-- simplifications).  Until phase zero we take no special notice of
-- top level things, but then we become more leery about inlining
1090
-- them.
1091