SimplUtils.hs 77.4 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, updModeForRuleLHS,
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 MkCore           ( sortQuantVars )
41
import DynFlags
42
import CoreSyn
43
import qualified CoreSubst
44
import PprCore
45
46
import CoreFVs
import CoreUtils
47
import CoreArity
48
import CoreUnfold
49
import Name
50
import Id
51
import Var
52
import Demand
53
import SimplMonad
54
import Type     hiding( substTy )
55
import Coercion hiding( substCo, substTy )
56
import DataCon          ( dataConWorkId )
57
import VarEnv
58
import VarSet
59
60
import BasicTypes
import Util
61
import MonadUtils
62
import Outputable
63
import FastString
64
import Pair
65

66
import Control.Monad    ( when )
67

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

75
A SimplCont allows the simplifier to traverse the expression in a
76
77
78
79
80
81
82
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
83
        C ::= []  |  C e   |  case C of alts  |  C `cast` co
84
85
86
87
88
That's the kind of thing we are doing here, and I use that syntax in
the comments.


Key points:
89
  * A SimplCont describes a *strict* context (just like
90
91
92
93
    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
94
-}
95

96
97
data SimplCont
  = Stop                -- An empty context, or <hole>
98
        OutType         -- Type of the <hole>
99
        CallCtxt        -- Tells if there is something interesting about
100
101
102
103
104
                        --          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
105
                        -- Never ValAppCxt (use ApplyToVal instead)
106
                        -- or CaseCtxt (use Select instead)
107

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

113
114
115
116
117
118
119
120
121
122
123
  | 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 }
124

125
126
127
128
129
130
  | 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 }
131

132
  -- The two strict forms have no DupFlag, because we never duplicate them
133
134
135
136
137
138
139
140
  | 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
141
        CallCtxt        -- Whether *this* argument position is interesting
142
        SimplCont
143

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

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
178
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
179
180
181
182
183
184
185
  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)
186
187
188
                                        $$ 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
189
190
191
  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
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
217


{- 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
*                                                                      *
************************************************************************
-}

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

224
225
226
227
228
229
230
231
232
233
234
235
        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
236
    }
237

238
239
240
241
242
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
243
244

instance Outputable ArgSpec where
245
246
247
248
249
250
251
  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
                        , ai_type = funResultTy (ai_type ai) }
252

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

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

264
265
266
267
268
269
270
271
272
273
274
275
276
277
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
278
  where
279
280
    rest = pushSimplifiedArgs env args k
           -- The env has an empty SubstEnv
281
282

argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
283
284
285
286
-- 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
287
  where
288
289
290
291
    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
292

293

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

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

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

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

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

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

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

331
-------------------
332
contIsTrivial :: SimplCont -> Bool
333
334
335
336
337
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
338

339
-------------------
340
contResultType :: SimplCont -> OutType
341
342
343
344
contResultType (Stop ty _)                  = ty
contResultType (CastIt _ k)                 = contResultType k
contResultType (StrictBind _ _ _ _ k)       = contResultType k
contResultType (StrictArg _ _ k)            = contResultType k
345
contResultType (Select { sc_cont = k })     = contResultType k
346
347
348
349
350
351
352
353
354
355
356
357
358
359
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)
360
361
contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
  = perhapsSubstTy d se (idType b)
362

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

countArgs :: SimplCont -> Int
372
373
374
375
-- 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
376

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

390
391
392
393
394
    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)
395

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

400

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

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

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

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

433
    arg_stricts
434
      = case splitStrictSig (idStrictness fun) of
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
          (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
452

453
454
455
456
    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.
457
    -- add_type_str is done repeatedly (for each call); might be better
458
459
    -- once-for-all in the function
    -- But beware primops/datacons with no strictness
Ian Lynagh's avatar
Ian Lynagh committed
460
    add_type_str _ [] = []
461
462
463
464
465
466
    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
467
    add_type_str _ strs
468
        = strs
469

470
471
472
{- Note [Unsaturated functions]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (test eyeball/inline4)
473
474
        x = a:as
        y = f x
475
476
477
478
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
-}
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
526

{-
************************************************************************
*                                                                      *
        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
527
528
    interesting (Select {})     = CaseCtxt
    interesting (ApplyToVal {}) = ValAppCtxt
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
        -- 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.

554
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
555
556
557
-- 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
558
--      g (f x y)
559
560
-- 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
561
--      h (g (f x x))
562
563
564
-- where h has rules, then we do want to inline f; hence the
-- call_cont argument to interestingArgContext
--
565
-- The ai-rules flag makes this happen; if it's
566
-- set, the inliner gets just enough keener to inline f
567
568
569
570
571
-- 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
572
573
574
--
-- The call_cont passed to interestingArgContext is the context of
-- the call itself, e.g. g <hole> in the example above
575
576
interestingArgContext rules call_cont
  = notNull rules || enclosing_fn_has_rules
577
  where
578
579
    enclosing_fn_has_rules = go call_cont

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

589
590
    interesting RuleArgCtxt = True
    interesting _           = False
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
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

{- 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

    go _   _ (Lit {})              = ValueArg
    go _   _ (Type _)              = TrivArg
    go _   _ (Coercion _)          = TrivArg
    go env n (App fn (Type _))     = go env n fn
    go env n (App fn (Coercion _)) = 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
    go env n (Lam v e)
       | isTyVar v                 = go env n     e
       | n>0                       = go env (n-1) e
       | otherwise                 = ValueArg
    go env n (Let _ e)             = case go env n e of { ValueArg -> ValueArg; _ -> NonTrivArg }
    go _ _ (Case {})               = NonTrivArg

    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
663
664
665
{-
************************************************************************
*                                                                      *
666
                  SimplifierMode
Austin Seipp's avatar
Austin Seipp committed
667
668
*                                                                      *
************************************************************************
669

670
671
672
673
674
675
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
676
-}
677

678
679
680
681
682
683
684
685
686
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
687
688
    rules_on      = gopt Opt_EnableRewriteRules   dflags
    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
689
690
   -- Do not do any inlining, in case we expose some unboxed
   -- tuple stuff that confuses the bytecode interpreter
691

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

704
updModeForRuleLHS :: SimplifierMode -> SimplifierMode
Simon Peyton Jones's avatar
Simon Peyton Jones committed
705
-- See Note [Simplifying rule LHSs]
706
707
708
709
710
711
updModeForRuleLHS current_mode
  = current_mode { sm_phase  = InitialPhase
                 , sm_inline = False
                 , sm_rules  = False
                 , sm_eta_expand = False }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
712
{- Note [Simplifying rule LHSs]
713
714
715
716
717
718
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When simplifying on the LHS of a rule, refrain from all inlining and
all RULES.  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
719
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
Note [Inlining in gentle mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
725
Something is inlined if
726
727
   (i)   the sm_inline flag is on, AND
   (ii)  the thing has an INLINE pragma, AND
728
   (iii) the thing is inlinable in the earliest phase.
729
730

Example of why (iii) is important:
731
732
  {-# INLINE [~1] g #-}
  g = ...
733

734
735
736
737
738
  {-# 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
739
        f e --> g (g e) ---> RULE fires
740
because the stable unfolding for f has had g inlined into it.
741
742

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
746
747
748
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
749
750
751
752
    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.
753

754
The no-inlining thing is also important for Template Haskell.  You might be
755
756
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
757
anything, because the byte-code interpreter might get confused about
758
unboxed tuples and suchlike.
759

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

765
First, consider the following example
766
767
768
769
770
        let f = \pq -> BIG
        in
        let g = \y -> f y y
            {-# INLINE g #-}
        in ...g...g...g...g...g...
771
772
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
773
any occurrence in a stable unfolding as a multiple occurrence, not a single
774
775
one; see OccurAnal.addRuleUsage.

776
777
778
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.
779
780

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

  -------------------------------------------------------------
790
791
  When simplifying the RHS of an stable unfolding, set the phase
  to the phase in which the stable unfolding first becomes active
792
793
794
795
  -------------------------------------------------------------

That ensures that

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

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

804
805
806
For example,
        {-# INLINE f #-}
        f x = ...g...
807

808
809
        {-# NOINLINE [1] g #-}
        g y = ...
810

811
        {-# RULE h g = ... #-}
812
813
814
815
816
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
817
818
        {-# INLINE f #-}
        f x = ...g...
819

820
        g y = ...
821
822
823
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
824
wrepper fails the test and won't be inlined into f's stable unfolding. That
825
826
means f can inline, expose the specialised call to g, so the specialisation
rules can fire.
827

828
829
A note about wrappers
~~~~~~~~~~~~~~~~~~~~~
830
831
It's also important not to inline a worker back into a wrapper.
A wrapper looks like
832
        wraper = inline_me (\x -> ...worker... )
833
834
835
836
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
837
continuation.
Austin Seipp's avatar
Austin Seipp committed
838
-}
839

840
activeUnfolding :: SimplEnv -> Id -> Bool
841
activeUnfolding env
842
843
844
845
846
847
  | 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
848

849
getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
850
-- When matching in RULE, we want to "look through" an unfolding
851
852
-- (to see a constructor) if *rules* are on, even if *inlinings*
-- are not.  A notable example is DFuns, which really we want to
853
854
855
-- 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
856
857
getUnfoldingInRuleMatch env
  = (in_scope, id_unf)
858
  where
859
    in_scope = seInScope env
860
    mode = getMode env
861
862
863
    id_unf id | unf_is_active id = idUnfolding id
              | otherwise        = NoUnfolding
    unf_is_active id
864
865
     | not (sm_rules mode) = active_unfolding_minimal id
     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
866

867
active_unfolding_minimal :: Id -> Bool
868
869
870
871
872
-- 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.
873
-- On the grounds that we use gentle mode for rule LHSs, and
874
875
876
877
-- 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.
878
879
880
881
active_unfolding_minimal id = isCompulsoryUnfolding (realIdUnfolding id)

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

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

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

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

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

921
922
923
924
925
        x1 = e1
        x2 = e2[x1]
        x3 = e3[x2]
        ...etc...
        xN = eN[xN-1]
926
927

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

930
931
932
933
        f1 = \x1.e1
        f2 = \xs.e2[f1]
        f3 = \xs.e3[f3]
        ...etc...
934
935
936

THE MAIN INVARIANT is this:

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

For example, it's tempting to look at trivial binding like
944
        x = y
945
946
947
948
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.
949
950


951
Even RHSs labelled InlineMe aren't caught here, because there might be
952
953
954
955
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.
956
957
        x = (a,b)
        main = \s -> h x
958
959
960
961
962
963
964
965
966
967
968
969
970
971

[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.
972

973
974
975
976
977
978
979
980
981
982
983
984
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].

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

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

994
995
996
997
998
   fInt :: Int -> Int
   fInt = f Int dEqInt

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

Joachim Breitner's avatar
Joachim Breitner committed
999
Here f occurs just once, in the RHS of fInt. But if we inline it there
1000
we'll lose the opportunity to inline at each of fInt's call sites.
For faster browsing, not all history is shown. View entire blame