SimplUtils.hs 92.5 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
20
        SimplCont(..), DupFlag(..), StaticEnv,
21
        isSimplified, contIsStop,
22
        contIsDupable, contResultType, contHoleType,
23
        contIsTrivial, contArgs,
24
        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 34 35 36
        abstractFloats,

        -- Utilities
        isExitJoinId
37 38
    ) where

39
#include "HsVersions.h"
40

41 42
import GhcPrelude

43
import SimplEnv
44
import CoreMonad        ( SimplMode(..), Tick(..) )
45
import DynFlags
46
import CoreSyn
47
import qualified CoreSubst
48
import PprCore
49 50
import CoreFVs
import CoreUtils
51
import CoreArity
52
import CoreUnfold
53
import Name
54
import Id
lukemaurer's avatar
lukemaurer committed
55
import IdInfo
56
import Var
57
import Demand
58
import SimplMonad
59
import Type     hiding( substTy )
60
import Coercion hiding( substCo )
61
import DataCon          ( dataConWorkId, isNullaryRepDataCon )
62
import VarSet
63 64
import BasicTypes
import Util
65
import OrdList          ( isNilOL )
66
import MonadUtils
67
import Outputable
68
import Pair
Sylvain Henry's avatar
Sylvain Henry committed
69
import PrelRules
70
import FastString       ( fsLit )
71

72
import Control.Monad    ( when )
73
import Data.List        ( sortBy )
74

Austin Seipp's avatar
Austin Seipp committed
75 76 77
{-
************************************************************************
*                                                                      *
78
                The SimplCont and DupFlag types
Austin Seipp's avatar
Austin Seipp committed
79 80
*                                                                      *
************************************************************************
81

82
A SimplCont allows the simplifier to traverse the expression in a
83 84 85 86 87 88 89
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
90
        C ::= []  |  C e   |  case C of alts  |  C `cast` co
91 92 93 94 95
That's the kind of thing we are doing here, and I use that syntax in
the comments.


Key points:
96
  * A SimplCont describes a *strict* context (just like
97 98 99 100
    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
101
-}
102

103
data SimplCont
Simon Peyton Jones's avatar
Simon Peyton Jones committed
104
  = Stop                -- Stop[e] = e
105
        OutType         -- Type of the <hole>
106
        CallCtxt        -- Tells if there is something interesting about
107 108 109 110 111
                        --          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
112
                        -- Never ValAppCxt (use ApplyToVal instead)
113
                        -- or CaseCtxt (use Select instead)
114

Simon Peyton Jones's avatar
Simon Peyton Jones committed
115
  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]
116 117 118 119
        OutCoercion             -- The coercion simplified
                                -- Invariant: never an identity coercion
        SimplCont

Simon Peyton Jones's avatar
Simon Peyton Jones committed
120 121 122
  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]
      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]
      , sc_arg  :: InExpr       -- The argument,
123
      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
124 125 126 127 128 129 130 131 132 133 134 135
      , sc_cont :: SimplCont }

  | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e 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 }

  | Select             -- (Select alts K)[e] = K[ case e of alts ]
      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]
      , sc_bndr :: InId           -- case binder
      , sc_alts :: [InAlt]        -- Alternatives
136
      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
137
      , sc_cont :: SimplCont }
138

139
  -- The two strict forms have no DupFlag, because we never duplicate them
Simon Peyton Jones's avatar
Simon Peyton Jones committed
140 141 142 143 144 145
  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]
                        --       or, equivalently,  = K[ (\x xs.b) e ]
      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]
      , sc_bndr  :: InId
      , sc_bndrs :: [InBndr]
      , sc_body  :: InExpr
146
      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
147 148 149 150 151 152 153 154 155 156
      , sc_cont  :: SimplCont }

  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]
      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup
      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc
                               --     plus strictness flags for *further* args
      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting
      , sc_cont :: SimplCont }

  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]
157
        (Tickish Id)    -- Tick tickish <hole>
158 159
        SimplCont

160 161
type StaticEnv = SimplEnv       -- Just the static part is relevant

162 163 164 165 166 167 168 169 170 171 172 173 174
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

175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
{- Note [StaticEnv invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pair up an InExpr or InAlts with a StaticEnv, which establishes the
lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we
use
  - Its captured StaticEnv
  - Overriding its InScopeSet with the larger one at the
    simplification point.

Why override the InScopeSet?  Example:
      (let y = ey in f) ex
By the time we simplify ex, 'y' will be in scope.

However the InScopeSet in the StaticEnv is not irrelevant: it should
include all the free vars of applying the substitution to the InExpr.
Reason: contHoleType uses perhapsSubstTy to apply the substitution to
the expression, and that (rightly) gives ASSERT failures if the InScopeSet
isn't big enough.

194 195 196 197 198 199 200 201 202 203 204 205
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
206 207 208
  ppr OkToDup    = text "ok"
  ppr NoDup      = text "nodup"
  ppr Simplified = text "simpl"
209 210

instance Outputable SimplCont where
211
  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty
212
  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont
213
  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont
214
  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })
215
    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
216
  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
217
    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
218
                                        $$ ppr cont
Simon Peyton Jones's avatar
Simon Peyton Jones committed
219 220 221 222
  ppr (StrictBind { sc_bndr = b, sc_cont = cont })
    = (text "StrictBind" <+> ppr b) $$ ppr cont
  ppr (StrictArg { sc_fun = ai, sc_cont = cont })
    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont
223
  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
224
    = (text "Select" <+> ppr dup <+> ppr bndr) $$
Simon Peyton Jones's avatar
Simon Peyton Jones committed
225
       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251


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

252
data ArgInfo
253
  = ArgInfo {
254
        ai_fun   :: OutId,      -- The function
255
        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)
256

257 258
        ai_type  :: OutType,    -- Type of (f a1 ... an)

259
        ai_rules :: FunRules,   -- Rules for this function
260 261 262 263 264 265 266 267 268 269 270

        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
271
    }
272

273 274 275 276 277
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
278 279

instance Outputable ArgSpec where
280 281 282
  ppr (ValArg e)                 = text "ValArg" <+> ppr e
  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
  ppr (CastBy c)                 = text "CastBy" <+> ppr c
283 284 285

addValArgTo :: ArgInfo -> OutExpr -> ArgInfo
addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai
286 287
                        , ai_type = applyTypeToArg (ai_type ai) arg
                        , ai_rules = decRules (ai_rules ai) }
288

289 290
addTyArgTo :: ArgInfo -> OutType -> ArgInfo
addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai
291 292
                          , ai_type = piResultTy poly_fun_ty arg_ty
                          , ai_rules = decRules (ai_rules ai) }
293 294 295
  where
    poly_fun_ty = ai_type ai
    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }
296

297 298 299 300
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo ai co = ai { ai_args = CastBy co : ai_args ai
                     , ai_type = pSnd (coercionKind co) }

301 302 303 304 305 306 307 308 309 310 311 312 313 314
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
315
  where
316 317
    rest = pushSimplifiedArgs env args k
           -- The env has an empty SubstEnv
318 319

argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
320 321 322 323
-- 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
324
  where
325 326 327 328
    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
329

330

331 332 333 334 335 336 337 338 339 340 341 342 343 344
type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function
     -- Nothing => No rules
     -- Just (n, rules) => some rules, requiring at least n more type/value args

decRules :: FunRules -> FunRules
decRules (Just (n, rules)) = Just (n-1, rules)
decRules Nothing           = Nothing

mkFunRules :: [CoreRule] -> FunRules
mkFunRules [] = Nothing
mkFunRules rs = Just (n_required, rs)
  where
    n_required = maximum (map ruleArity rs)

Austin Seipp's avatar
Austin Seipp committed
345
{-
346 347 348 349 350
************************************************************************
*                                                                      *
                Functions on SimplCont
*                                                                      *
************************************************************************
Austin Seipp's avatar
Austin Seipp committed
351
-}
352

353 354
mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty BoringCtxt
355

356
mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold
357
mkRhsStop ty = Stop ty RhsCtxt
358

359 360
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop ty cci = Stop ty cci
361

362
-------------------
Ian Lynagh's avatar
Ian Lynagh committed
363 364 365 366 367
contIsRhsOrArg :: SimplCont -> Bool
contIsRhsOrArg (Stop {})       = True
contIsRhsOrArg (StrictBind {}) = True
contIsRhsOrArg (StrictArg {})  = True
contIsRhsOrArg _               = False
368

369 370 371 372
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ RhsCtxt) = True
contIsRhs _                = False

373
-------------------
374 375 376 377
contIsStop :: SimplCont -> Bool
contIsStop (Stop {}) = True
contIsStop _         = False

378
contIsDupable :: SimplCont -> Bool
379 380 381
contIsDupable (Stop {})                         = True
contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k
contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]
382
contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...
Simon Peyton Jones's avatar
Simon Peyton Jones committed
383
contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...
384 385
contIsDupable (CastIt _ k)                      = contIsDupable k
contIsDupable _                                 = False
386

387
-------------------
388
contIsTrivial :: SimplCont -> Bool
389 390 391 392 393
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
394

395
-------------------
396
contResultType :: SimplCont -> OutType
397 398
contResultType (Stop ty _)                  = ty
contResultType (CastIt _ k)                 = contResultType k
Simon Peyton Jones's avatar
Simon Peyton Jones committed
399 400
contResultType (StrictBind { sc_cont = k }) = contResultType k
contResultType (StrictArg { sc_cont = k })  = contResultType k
401
contResultType (Select { sc_cont = k })     = contResultType k
402 403 404 405 406 407 408 409
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)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
410 411 412
contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
  = perhapsSubstTy dup se (idType b)
contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)
413 414 415 416
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)
417 418
contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
  = perhapsSubstTy d se (idType b)
419

420
-------------------
421
countArgs :: SimplCont -> Int
422 423 424 425
-- 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
426

427
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
428
-- Summarises value args, discards type args and coercions
Austin Seipp's avatar
Austin Seipp committed
429
-- The returned continuation of the call is only used to
430 431 432 433
-- answer questions like "are you interesting?"
contArgs cont
  | lone cont = (True, [], cont)
  | otherwise = go [] cont
434
  where
435 436 437 438
    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold
    lone (ApplyToVal {}) = False
    lone (CastIt {})     = False
    lone _               = True
439

440 441 442 443 444
    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)
445

446
    is_interesting arg se = interestingArg se arg
447 448
                   -- Do *not* use short-cutting substitution here
                   -- because we want to get as much IdInfo as possible
449

450

451
-------------------
452 453
mkArgInfo :: SimplEnv
          -> Id
454 455 456 457
          -> [CoreRule] -- Rules for function
          -> Int        -- Number of value args
          -> SimplCont  -- Context of the call
          -> ArgInfo
458

459
mkArgInfo env fun rules n_val_args call_cont
460
  | n_val_args < idArity fun            -- Note [Unsaturated functions]
461
  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
462 463
            , ai_rules = fun_rules
            , ai_encl = False
464 465
            , ai_strs = vanilla_stricts
            , ai_discs = vanilla_discounts }
466
  | otherwise
467
  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
468
            , ai_rules = fun_rules
469 470
            , ai_encl  = interestingArgContext rules call_cont
            , ai_strs  = arg_stricts
471
            , ai_discs = arg_discounts }
472
  where
473 474
    fun_ty = idType fun

475 476
    fun_rules = mkFunRules rules

477 478 479
    vanilla_discounts, arg_discounts :: [Int]
    vanilla_discounts = repeat 0
    arg_discounts = case idUnfolding fun of
480 481 482
                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}
                              -> discounts ++ vanilla_discounts
                        _     -> vanilla_discounts
483 484

    vanilla_stricts, arg_stricts :: [Bool]
485 486
    vanilla_stricts  = repeat False

487
    arg_stricts
488 489 490 491 492
      | not (sm_inline (seMode env))
      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]
      | otherwise
      = add_type_str fun_ty $
        case splitStrictSig (idStrictness fun) of
493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509
          (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
510

511 512 513
    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
514 515 516
    --   types) can't instantiate type variables.
    -- add_type_str is done repeatedly (for each call);
    --   might be better once-for-all in the function
517
    -- But beware primops/datacons with no strictness
Richard Eisenberg's avatar
Richard Eisenberg committed
518

519 520 521 522 523 524 525 526 527 528 529 530 531 532
    add_type_str _ [] = []
    add_type_str fun_ty all_strs@(str:strs)
      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info
      = (str || Just False == isLiftedType_maybe arg_ty)
        : add_type_str fun_ty' strs
          -- If the type is levity-polymorphic, we can't know whether it's
          -- strict. isLiftedType_maybe will return Just False only when
          -- we're sure the type is unlifted.

      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
      = add_type_str fun_ty' all_strs     -- Look through foralls

      | otherwise
      = all_strs
533

534 535 536
{- Note [Unsaturated functions]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (test eyeball/inline4)
537 538
        x = a:as
        y = f x
539 540 541
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
542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563

Note [Do not expose strictness if sm_inline=False]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trac #15163 showed a case in which we had

  {-# INLINE [1] zip #-}
  zip = undefined

  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}

If we expose zip's bottoming nature when simplifing the LHS of the
RULE we get
  {-# RULES "foo" forall as bs.
                   stream (case zip of {}) = ..blah... #-}
discarding the arguments to zip.  Usually this is fine, but on the
LHS of a rule it's not, because 'as' and 'bs' are now not bound on
the LHS.

This is a pretty pathalogical example, so I'm not losing sleep over
it, but the simplest solution was to check sm_inline; if it is False,
which it is on the LHS of a rule (see updModeForRules), then don't
make use of the strictness info for the function.
564
-}
565

566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605

{-
************************************************************************
*                                                                      *
        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.
606 607 608 609 610 611 612 613 614 615 616 617 618

Note [No case of case is boring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we see
   case f x of <alts>

we'd usually treat the context as interesting, to encourage 'f' to
inline.  But if case-of-case is off, it's really not so interesting
after all, because we are unlikely to be able to push the case
expression into the branches of any case in f's unfolding.  So, to
reduce unnecessary code expansion, we just make the context look boring.
This made a small compile-time perf improvement in perf/compiler/T6048,
and it looks plausible to me.
619 620
-}

621
interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
622
-- See Note [Interesting call context]
623
interestingCallContext env cont
624 625
  = interesting cont
  where
626 627 628 629 630
    interesting (Select {})
       | sm_case_case (getMode env) = CaseCtxt
       | otherwise                  = BoringCtxt
       -- See Note [No case of case is boring]

631
    interesting (ApplyToVal {}) = ValAppCtxt
632 633 634 635
        -- 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
636

Simon Peyton Jones's avatar
Simon Peyton Jones committed
637 638 639 640 641 642
    interesting (StrictArg { sc_cci = 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
643 644 645 646 647 648 649 650 651 652 653 654 655 656 657
        -- 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.

658
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
659 660 661
-- 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
662
--      g (f x y)
663 664
-- 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
665
--      h (g (f x x))
666 667 668
-- where h has rules, then we do want to inline f; hence the
-- call_cont argument to interestingArgContext
--
669
-- The ai-rules flag makes this happen; if it's
670
-- set, the inliner gets just enough keener to inline f
671 672 673 674 675
-- 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
676 677 678
--
-- The call_cont passed to interestingArgContext is the context of
-- the call itself, e.g. g <hole> in the example above
679 680
interestingArgContext rules call_cont
  = notNull rules || enclosing_fn_has_rules
681
  where
682 683
    enclosing_fn_has_rules = go call_cont

Simon Peyton Jones's avatar
Simon Peyton Jones committed
684 685 686 687 688 689 690 691
    go (Select {})                  = False
    go (ApplyToVal {})              = False  -- Shouldn't really happen
    go (ApplyToTy  {})              = False  -- Ditto
    go (StrictArg { sc_cci = cci }) = interesting cci
    go (StrictBind {})              = False      -- ??
    go (CastIt _ c)                 = go c
    go (Stop _ cci)                 = interesting cci
    go (TickIt _ c)                 = go c
692

693 694
    interesting RuleArgCtxt = True
    interesting _           = False
695

696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733

{- 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)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
734 735 736 737
       = case substId env v of
           DoneId v'            -> go_var n v'
           DoneEx e _           -> go (zapSubstEnv env)             n e
           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
738

739 740 741 742 743 744 745
    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
746
    go env n (Lam v e)
747 748 749 750 751 752 753 754 755
       | 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
756 757 758 759 760 761 762 763 764 765 766 767

    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
768 769 770
{-
************************************************************************
*                                                                      *
771
                  SimplMode
Austin Seipp's avatar
Austin Seipp committed
772 773
*                                                                      *
************************************************************************
774

775
The SimplMode controls several switches; see its definition in
776 777 778 779 780
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
781
-}
782

783 784
simplEnvForGHCi :: DynFlags -> SimplEnv
simplEnvForGHCi dflags
785 786 787 788
  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]
                           , sm_phase  = InitialPhase
                           , sm_dflags = dflags
                           , sm_rules  = rules_on
789 790
                           , sm_inline = False
                           , sm_eta_expand = eta_expand_on
791
                           , sm_case_case  = True }
792
  where
ian@well-typed.com's avatar
ian@well-typed.com committed
793 794
    rules_on      = gopt Opt_EnableRewriteRules   dflags
    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
795 796
   -- Do not do any inlining, in case we expose some unboxed
   -- tuple stuff that confuses the bytecode interpreter
797

798
updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
799 800
-- See Note [Simplifying inside stable unfoldings]
updModeForStableUnfoldings inline_rule_act current_mode
801 802
  = current_mode { sm_phase      = phaseFromActivation inline_rule_act
                 , sm_inline     = True
803
                 , sm_eta_expand = False }
804 805 806
                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]
       -- For sm_rules, just inherit; sm_rules might be "off"
       -- because of -fno-enable-rewrite-rules
807
  where
808 809
    phaseFromActivation (ActiveAfter _ n) = Phase n
    phaseFromActivation _                 = InitialPhase
810

811
updModeForRules :: SimplMode -> SimplMode
812 813
-- See Note [Simplifying rules]
updModeForRules current_mode
814 815 816
  = current_mode { sm_phase      = InitialPhase
                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]
                 , sm_rules      = False
817 818
                 , sm_eta_expand = False }

819
{- Note [Simplifying rules]
820
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
821 822
When simplifying a rule LHS, refrain from /any/ inlining or applying
of other RULES.
823

824 825
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
826 827 828
Moreover, inlining (or applying rules) on rule LHSs risks introducing
Ticks into the LHS, which makes matching trickier. Trac #10665, #10745.

829 830
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
831

832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850
Note [No eta expansion in stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have a stable unfolding

  f :: Ord a => a -> IO ()
  -- Unfolding template
  --    = /\a \(d:Ord a) (x:a). bla

we do not want to eta-expand to

  f :: Ord a => a -> IO ()
  -- Unfolding template
  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co

because not specialisation of the overloading doesn't work properly
(see Note [Specialisation shape] in Specialise), Trac #9509.

So we disable eta-expansion in stable unfoldings.

851 852
Note [Inlining in gentle mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
853
Something is inlined if
854 855
   (i)   the sm_inline flag is on, AND
   (ii)  the thing has an INLINE pragma, AND
856
   (iii) the thing is inlinable in the earliest phase.
857 858

Example of why (iii) is important:
859 860
  {-# INLINE [~1] g #-}
  g = ...
861

862 863 864 865 866
  {-# 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
867
        f e --> g (g e) ---> RULE fires
868
because the stable unfolding for f has had g inlined into it.
869 870

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
874 875 876
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
877 878 879 880
    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.
881

882
The no-inlining thing is also important for Template Haskell.  You might be
883 884
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
885
anything, because the byte-code interpreter might get confused about
886
unboxed tuples and suchlike.
887

888 889 890
Note [Simplifying inside stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must take care with simplification inside stable unfoldings (which come from
891
INLINE pragmas).
892

893
First, consider the following example
894 895 896 897 898
        let f = \pq -> BIG
        in
        let g = \y -> f y y
            {-# INLINE g #-}
        in ...g...g...g...g...g...
899 900
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
901
any occurrence in a stable unfolding as a multiple occurrence, not a single
902 903
one; see OccurAnal.addRuleUsage.

904 905 906
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.
907 908

However, suppose we have
909 910 911
        {-# INLINE <act> f #-}
        f = <rhs>
meaning "inline f in phases p where activation <act>(p) holds".
912
Then what inlinings/rules can we apply to the copy of <rhs> captured in
913
f's stable unfolding?  Our model is that literally <rhs> is substituted for
914
f when it is inlined.  So our conservative plan (implemented by
915
updModeForStableUnfoldings) is this:
916 917

  -------------------------------------------------------------
Gabor Greif's avatar
Gabor Greif committed
918
  When simplifying the RHS of a stable unfolding, set the phase
919
  to the phase in which the stable unfolding first becomes active
920 921 922 923
  -------------------------------------------------------------

That ensures that

924
  a) Rules/inlinings that *cease* being active before p will
925
     not apply to the stable unfolding, consistent with it being
926 927 928
     inlined in its *original* form in phase p.

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

932 933 934
For example,
        {-# INLINE f #-}
        f x = ...g...
935

936 937
        {-# NOINLINE [1] g #-}
        g y = ...
938

939
        {-# RULE h g = ... #-}
940 941 942 943 944
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
945 946
        {-# INLINE f #-}
        f x = ...g...
947

948
        g y = ...
949 950 951
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
952
wrepper fails the test and won't be inlined into f's stable unfolding. That
simonpj@microsoft.com's avatar