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

4
\section[Simplify]{The main module of the simplifier}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}

9
module Simplify ( simplTopBinds, simplExpr, simplRules ) where
10

11
#include "HsVersions.h"
12

simonpj@microsoft.com's avatar
Wibble  
simonpj@microsoft.com committed
13
import DynFlags
14
import SimplMonad
15
import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )
Ian Lynagh's avatar
Ian Lynagh committed
16
import SimplEnv
17
import SimplUtils
18
import FamInstEnv       ( FamInstEnv )
19
import Literal          ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326
20
import Id
21
import MkId             ( seqId, voidPrimId )
22
import MkCore           ( mkImpossibleExpr, castBottomExpr )
23
import IdInfo
24
import Name             ( Name, mkSystemVarName, isExternalName, getOccFS )
25
import Coercion hiding  ( substCo, substCoVar )
26
import OptCoercion      ( optCoercion )
27
import FamInstEnv       ( topNormaliseType_maybe )
28
import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
29
                        , isMarkedStrict, dataConRepArgTys ) --, dataConTyCon, dataConTag, fIRST_TAG )
30
--import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
31
import CoreMonad        ( Tick(..), SimplifierMode(..) )
32
import CoreSyn
33
import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd )
34
import PprCore          ( pprCoreExpr )
35
import CoreUnfold
36
import CoreUtils
37
import CoreArity
38
--import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
39
import Rules            ( mkRuleInfo, lookupRule, getRules )
40
import TysPrim          ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
41
import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
42
import MonadUtils       ( foldlM, mapAccumLM, liftIO )
43
import Maybes           ( orElse )
44
--import Unique           ( hasKey ) -- temporalily commented out. See #8326
ian@well-typed.com's avatar
ian@well-typed.com committed
45
import Control.Monad
46
import Outputable
47
import FastString
48
import Pair
49
import Util
50
import ErrUtils
51

Austin Seipp's avatar
Austin Seipp committed
52
{-
53
The guts of the simplifier is in this module, but the driver loop for
54
the simplifier is in SimplCore.hs.
55 56


57
-----------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
58
        *** IMPORTANT NOTE ***
59 60 61 62 63 64
-----------------------------------------
The simplifier used to guarantee that the output had no shadowing, but
it does not do so any more.   (Actually, it never did!)  The reason is
documented with simplifyArgs.


65
-----------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
66
        *** IMPORTANT NOTE ***
67 68 69 70 71 72 73 74 75 76
-----------------------------------------
Many parts of the simplifier return a bunch of "floats" as well as an
expression. This is wrapped as a datatype SimplUtils.FloatsWith.

All "floats" are let-binds, not case-binds, but some non-rec lets may
be unlifted (with RHS ok-for-speculation).



-----------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
77
        ORGANISATION OF FUNCTIONS
78 79 80 81 82 83
-----------------------------------------
simplTopBinds
  - simplify all top-level binders
  - for NonRec, call simplRecOrTopPair
  - for Rec,    call simplRecBind

Ian Lynagh's avatar
Ian Lynagh committed
84 85 86

        ------------------------------
simplExpr (applied lambda)      ==> simplNonRecBind
87 88 89
simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind

Ian Lynagh's avatar
Ian Lynagh committed
90 91
        ------------------------------
simplRecBind    [binders already simplfied]
92 93 94 95
  - use simplRecOrTopPair on each pair in turn

simplRecOrTopPair [binder already simplified]
  Used for: recursive bindings (top level and nested)
Ian Lynagh's avatar
Ian Lynagh committed
96 97
            top-level non-recursive bindings
  Returns:
98 99 100 101 102
  - check for PreInlineUnconditionally
  - simplLazyBind

simplNonRecBind
  Used for: non-top-level non-recursive bindings
Ian Lynagh's avatar
Ian Lynagh committed
103 104 105
            beta reductions (which amount to the same thing)
  Because it can deal with strict arts, it takes a
        "thing-inside" and returns an expression
106 107 108 109

  - check for PreInlineUnconditionally
  - simplify binder, including its IdInfo
  - if strict binding
Ian Lynagh's avatar
Ian Lynagh committed
110 111 112
        simplStrictArg
        mkAtomicArgs
        completeNonRecX
113
    else
Ian Lynagh's avatar
Ian Lynagh committed
114 115
        simplLazyBind
        addFloats
116

Ian Lynagh's avatar
Ian Lynagh committed
117
simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
118 119 120 121
  Used for: binding case-binder and constr args in a known-constructor case
  - check for PreInLineUnconditionally
  - simplify binder
  - completeNonRecX
Ian Lynagh's avatar
Ian Lynagh committed
122 123 124

        ------------------------------
simplLazyBind:  [binder already simplified, RHS not]
125
  Used for: recursive bindings (top level and nested)
Ian Lynagh's avatar
Ian Lynagh committed
126 127 128
            top-level non-recursive bindings
            non-top-level, but *lazy* non-recursive bindings
        [must not be strict or unboxed]
129
  Returns floats + an augmented environment, not an expression
Ian Lynagh's avatar
Ian Lynagh committed
130 131
  - substituteIdInfo and add result to in-scope
        [so that rules are available in rec rhs]
132 133 134
  - simplify rhs
  - mkAtomicArgs
  - float if exposes constructor or PAP
135
  - completeBind
136 137


Ian Lynagh's avatar
Ian Lynagh committed
138
completeNonRecX:        [binder and rhs both simplified]
139
  - if the the thing needs case binding (unlifted and not ok-for-spec)
Ian Lynagh's avatar
Ian Lynagh committed
140
        build a Case
141
   else
Ian Lynagh's avatar
Ian Lynagh committed
142 143
        completeBind
        addFloats
144

Ian Lynagh's avatar
Ian Lynagh committed
145 146
completeBind:   [given a simplified RHS]
        [used for both rec and non-rec bindings, top level and not]
147 148 149 150 151 152 153 154
  - try PostInlineUnconditionally
  - add unfolding [this is the only place we add an unfolding]
  - add arity



Right hand sides and arguments
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ian Lynagh's avatar
Ian Lynagh committed
155 156 157
In many ways we want to treat
        (a) the right hand side of a let(rec), and
        (b) a function argument
158 159 160
in the same way.  But not always!  In particular, we would
like to leave these arguments exactly as they are, so they
will match a RULE more easily.
Ian Lynagh's avatar
Ian Lynagh committed
161 162 163

        f (g x, h x)
        g (+ x)
164 165 166 167

It's harder to make the rule match if we ANF-ise the constructor,
or eta-expand the PAP:

Ian Lynagh's avatar
Ian Lynagh committed
168 169
        f (let { a = g x; b = h x } in (a,b))
        g (\y. + x y)
170 171 172

On the other hand if we see the let-defns

Ian Lynagh's avatar
Ian Lynagh committed
173 174
        p = (g x, h x)
        q = + x
175 176

then we *do* want to ANF-ise and eta-expand, so that p and q
Ian Lynagh's avatar
Ian Lynagh committed
177
can be safely inlined.
178 179 180 181 182

Even floating lets out is a bit dubious.  For let RHS's we float lets
out if that exposes a value, so that the value can be inlined more vigorously.
For example

Ian Lynagh's avatar
Ian Lynagh committed
183
        r = let x = e in (x,x)
184 185 186 187 188 189 190 191 192 193 194 195 196 197

Here, if we float the let out we'll expose a nice constructor. We did experiments
that showed this to be a generally good thing.  But it was a bad thing to float
lets out unconditionally, because that meant they got allocated more often.

For function arguments, there's less reason to expose a constructor (it won't
get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
So for the moment we don't float lets out of function arguments either.


Eta expansion
~~~~~~~~~~~~~~
For eta expansion, we want to catch things like

Ian Lynagh's avatar
Ian Lynagh committed
198
        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
199 200 201 202 203

If the \x was on the RHS of a let, we'd eta expand to bring the two
lambdas together.  And in general that's a good thing to do.  Perhaps
we should eta expand wherever we find a (value) lambda?  Then the eta
expansion at a let RHS can concentrate solely on the PAP case.
204 205


Austin Seipp's avatar
Austin Seipp committed
206 207
************************************************************************
*                                                                      *
208
\subsection{Bindings}
Austin Seipp's avatar
Austin Seipp committed
209 210 211
*                                                                      *
************************************************************************
-}
212

213
simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
214

Ian Lynagh's avatar
Ian Lynagh committed
215
simplTopBinds env0 binds0
Ian Lynagh's avatar
Ian Lynagh committed
216 217 218 219
  = do  {       -- Put all the top-level binders into scope at the start
                -- so that if a transformation rule has unexpectedly brought
                -- anything into scope, then we don't get a complaint about that.
                -- It's rather as if the top-level binders were imported.
220
                -- See note [Glomming] in OccurAnal.
Ian Lynagh's avatar
Ian Lynagh committed
221
        ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
222
        ; env2 <- simpl_binds env1 binds0
Ian Lynagh's avatar
Ian Lynagh committed
223
        ; freeTick SimplifierDone
224
        ; return env2 }
225
  where
Ian Lynagh's avatar
Ian Lynagh committed
226 227 228 229
        -- We need to track the zapped top-level binders, because
        -- they should have their fragile IdInfo zapped (notably occurrence info)
        -- That's why we run down binds and bndrs' simultaneously.
        --
230 231 232 233
    simpl_binds :: SimplEnv -> [InBind] -> SimplM SimplEnv
    simpl_binds env []           = return env
    simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind
                                      ; simpl_binds env' binds }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
234

235
    simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
236 237
    simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b)
                                     ; simplRecOrTopPair env' TopLevel NonRecursive b b' r }
238

Austin Seipp's avatar
Austin Seipp committed
239 240 241
{-
************************************************************************
*                                                                      *
242
\subsection{Lazy bindings}
Austin Seipp's avatar
Austin Seipp committed
243 244
*                                                                      *
************************************************************************
245 246

simplRecBind is used for
Ian Lynagh's avatar
Ian Lynagh committed
247
        * recursive bindings only
Austin Seipp's avatar
Austin Seipp committed
248
-}
249 250

simplRecBind :: SimplEnv -> TopLevelFlag
Ian Lynagh's avatar
Ian Lynagh committed
251 252
             -> [(InId, InExpr)]
             -> SimplM SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
253
simplRecBind env0 top_lvl pairs0
254
  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
Ian Lynagh's avatar
Ian Lynagh committed
255 256 257
        ; env1 <- go (zapFloats env_with_info) triples
        ; return (env0 `addRecFloats` env1) }
        -- addFloats adds the floats from env1,
Thomas Schilling's avatar
Thomas Schilling committed
258
        -- _and_ updates env0 with the in-scope set from env1
259
  where
260
    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
Ian Lynagh's avatar
Ian Lynagh committed
261
        -- Add the (substituted) rules to the binder
262 263 264
    add_rules env (bndr, rhs)
        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr)
             ; return (env', (bndr, bndr', rhs)) }
265

266
    go env [] = return env
Ian Lynagh's avatar
Ian Lynagh committed
267

268
    go env ((old_bndr, new_bndr, rhs) : pairs)
269
        = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
Ian Lynagh's avatar
Ian Lynagh committed
270
             ; go env' pairs }
271

Austin Seipp's avatar
Austin Seipp committed
272
{-
273
simplOrTopPair is used for
Ian Lynagh's avatar
Ian Lynagh committed
274 275
        * recursive bindings (whether top level or not)
        * top-level non-recursive bindings
276 277

It assumes the binder has already been simplified, but not its IdInfo.
Austin Seipp's avatar
Austin Seipp committed
278
-}
279 280

simplRecOrTopPair :: SimplEnv
281
                  -> TopLevelFlag -> RecFlag
Ian Lynagh's avatar
Ian Lynagh committed
282 283
                  -> InId -> OutBndr -> InExpr  -- Binder and rhs
                  -> SimplM SimplEnv    -- Returns an env that includes the binding
284

285
simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
286 287 288 289
  = do { dflags <- getDynFlags
       ; trace_bind dflags $
           if preInlineUnconditionally dflags env top_lvl old_bndr rhs
                    -- Check for unconditional inline
290 291
           then do tick (PreInlineUnconditionally old_bndr)
                   return (extendIdSubst env old_bndr (mkContEx env rhs))
292 293 294 295 296 297 298 299 300
           else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env }
  where
    trace_bind dflags thing_inside
      | not (dopt Opt_D_verbose_core2core dflags)
      = thing_inside
      | otherwise
      = pprTrace "SimplBind" (ppr old_bndr) thing_inside
        -- trace_bind emits a trace for each top-level binding, which
        -- helps to locate the tracing for inlining and rule firing
301

Austin Seipp's avatar
Austin Seipp committed
302
{-
303
simplLazyBind is used for
304 305
  * [simplRecOrTopPair] recursive bindings (whether top level or not)
  * [simplRecOrTopPair] top-level non-recursive bindings
Ian Lynagh's avatar
Ian Lynagh committed
306
  * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
307 308

Nota bene:
Ian Lynagh's avatar
Ian Lynagh committed
309
    1. It assumes that the binder is *already* simplified,
310
       and is in scope, and its IdInfo too, except unfolding
311 312 313

    2. It assumes that the binder type is lifted.

314
    3. It does not check for pre-inline-unconditionally;
315
       that should have been done already.
Austin Seipp's avatar
Austin Seipp committed
316
-}
317 318

simplLazyBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
319 320 321 322 323
              -> TopLevelFlag -> RecFlag
              -> InId -> OutId          -- Binder, both pre-and post simpl
                                        -- The OutId has IdInfo, except arity, unfolding
              -> InExpr -> SimplEnv     -- The RHS and its environment
              -> SimplM SimplEnv
324
-- Precondition: rhs obeys the let/app invariant
325
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
326 327
  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
    do  { let   rhs_env     = rhs_se `setInScope` env
328 329 330 331 332 333 334 335 336 337
                (tvs, body) = case collectTyAndValBinders rhs of
                                (tvs, [], body)
                                  | surely_not_lam body -> (tvs, body)
                                _                       -> ([], rhs)

                surely_not_lam (Lam {})     = False
                surely_not_lam (Tick t e)
                  | not (tickishFloatable t) = surely_not_lam e
                   -- eta-reduction could float
                surely_not_lam _            = True
338
                        -- Do not do the "abstract tyyvar" thing if there's
Gabor Greif's avatar
typos  
Gabor Greif committed
339
                        -- a lambda inside, because it defeats eta-reduction
340
                        --    f = /\a. \x. g a x
Peter Wortmann's avatar
Peter Wortmann committed
341
                        -- should eta-reduce.
342

343

Ian Lynagh's avatar
Ian Lynagh committed
344
        ; (body_env, tvs') <- simplBinders rhs_env tvs
345
                -- See Note [Floating and type abstraction] in SimplUtils
Ian Lynagh's avatar
Ian Lynagh committed
346

347
        -- Simplify the RHS
348 349
        ; let   rhs_cont = mkRhsStop (substTy body_env (exprType body))
        ; (body_env1, body1) <- simplExprF body_env body rhs_cont
Ian Lynagh's avatar
Ian Lynagh committed
350
        -- ANF-ise a constructor or PAP rhs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
351
        ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
Ian Lynagh's avatar
Ian Lynagh committed
352 353 354

        ; (env', rhs')
            <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
355
                then                            -- No floating, revert to body1
356
                     do { rhs' <- mkLam tvs' (wrapFloats body_env1 body1) rhs_cont
Ian Lynagh's avatar
Ian Lynagh committed
357 358 359 360 361 362 363 364 365
                        ; return (env, rhs') }

                else if null tvs then           -- Simple floating
                     do { tick LetFloatFromLet
                        ; return (addFloats env body_env2, body2) }

                else                            -- Do type-abstraction first
                     do { tick LetFloatFromLet
                        ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
366
                        ; rhs' <- mkLam tvs' body3 rhs_cont
367
                        ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
368
                        ; return (env', rhs') }
Ian Lynagh's avatar
Ian Lynagh committed
369 370

        ; completeBind env' top_lvl bndr bndr1 rhs' }
371

Austin Seipp's avatar
Austin Seipp committed
372
{-
Ian Lynagh's avatar
Ian Lynagh committed
373
A specialised variant of simplNonRec used when the RHS is already simplified,
374
notably in knownCon.  It uses case-binding where necessary.
Austin Seipp's avatar
Austin Seipp committed
375
-}
376 377

simplNonRecX :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
378 379 380
             -> InId            -- Old binder
             -> OutExpr         -- Simplified RHS
             -> SimplM SimplEnv
381
-- Precondition: rhs satisfies the let/app invariant
382
simplNonRecX env bndr new_rhs
383
  | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
384 385 386
  = return env    --  Here c is dead, and we avoid creating
                  --   the binding c = (a,b)

387
  | Coercion co <- new_rhs
388
  = return (extendCvSubst env bndr co)
389 390

  | otherwise
Ian Lynagh's avatar
Ian Lynagh committed
391
  = do  { (env', bndr') <- simplBinder env bndr
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
392
        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
393
                -- simplNonRecX is only used for NotTopLevel things
394

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
395
completeNonRecX :: TopLevelFlag -> SimplEnv
396
                -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
397 398 399 400
                -> InId                 -- Old binder
                -> OutId                -- New binder
                -> OutExpr              -- Simplified RHS
                -> SimplM SimplEnv
401 402
-- Precondition: rhs satisfies the let/app invariant
--               See Note [CoreSyn let/app invariant] in CoreSyn
403

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
404 405
completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
  = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
406
        ; (env2, rhs2) <-
407
                if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
Ian Lynagh's avatar
Ian Lynagh committed
408 409 410 411
                then do { tick LetFloatFromLet
                        ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
                else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
        ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
412

Austin Seipp's avatar
Austin Seipp committed
413
{-
414 415
{- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
   Doing so risks exponential behaviour, because new_rhs has been simplified once already
Ian Lynagh's avatar
Ian Lynagh committed
416
   In the cases described by the folowing commment, postInlineUnconditionally will
417
   catch many of the relevant cases.
Ian Lynagh's avatar
Ian Lynagh committed
418 419 420 421 422 423 424 425
        -- This happens; for example, the case_bndr during case of
        -- known constructor:  case (a,b) of x { (p,q) -> ... }
        -- Here x isn't mentioned in the RHS, so we don't want to
        -- create the (dead) let-binding  let x = (a,b) in ...
        --
        -- Similarly, single occurrences can be inlined vigourously
        -- e.g.  case (f x, g y) of (a,b) -> ....
        -- If a,b occur once we can avoid constructing the let binding for them.
426

427
   Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
Ian Lynagh's avatar
Ian Lynagh committed
428 429 430 431 432 433
        -- Consider     case I# (quotInt# x y) of
        --                I# v -> let w = J# v in ...
        -- If we gaily inline (quotInt# x y) for v, we end up building an
        -- extra thunk:
        --                let w = J# (quotInt# x y) in ...
        -- because quotInt# can fail.
434

435 436 437 438
  | preInlineUnconditionally env NotTopLevel bndr new_rhs
  = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
-}

439
----------------------------------
440
prepareRhs takes a putative RHS, checks whether it's a PAP or
Ian Lynagh's avatar
Ian Lynagh committed
441
constructor application and, if so, converts it to ANF, so that the
442
resulting thing can be inlined more easily.  Thus
Ian Lynagh's avatar
Ian Lynagh committed
443
        x = (f a, g b)
444
becomes
Ian Lynagh's avatar
Ian Lynagh committed
445 446 447
        t1 = f a
        t2 = g b
        x = (t1,t2)
448

449
We also want to deal well cases like this
Ian Lynagh's avatar
Ian Lynagh committed
450
        v = (f e1 `cast` co) e2
451
Here we want to make e1,e2 trivial and get
Ian Lynagh's avatar
Ian Lynagh committed
452
        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
453
That's what the 'go' loop in prepareRhs does
Austin Seipp's avatar
Austin Seipp committed
454
-}
455

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
456
prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
457
-- Adds new floats to the env iff that allows us to return a good RHS
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
458
prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
459
  | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
460
  , not (isUnliftedType ty1)            -- see Note [Float coercions (unlifted)]
461
  = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env (getOccFS id) sanitised_info rhs
Ian Lynagh's avatar
Ian Lynagh committed
462
        ; return (env', Cast rhs' co) }
463
  where
464
    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
465
                                   `setDemandInfo` demandInfo info
466
    info = idInfo id
467

468
prepareRhs top_lvl env0 id rhs0
469
  = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
Ian Lynagh's avatar
Ian Lynagh committed
470
        ; return (env1, rhs1) }
471
  where
472
    go n_val_args env (Cast rhs co)
473 474
        = do { (is_exp, env', rhs') <- go n_val_args env rhs
             ; return (is_exp, env', Cast rhs' co) }
475
    go n_val_args env (App fun (Type ty))
476 477
        = do { (is_exp, env', rhs') <- go n_val_args env fun
             ; return (is_exp, env', App rhs' (Type ty)) }
478
    go n_val_args env (App fun arg)
479 480
        = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
             ; case is_exp of
481
                True -> do { (env'', arg') <- makeTrivial top_lvl env' (getOccFS id) arg
Ian Lynagh's avatar
Ian Lynagh committed
482 483
                           ; return (True, env'', App fun' arg') }
                False -> return (False, env, App fun arg) }
484
    go n_val_args env (Var fun)
485
        = return (is_exp, env, Var fun)
Ian Lynagh's avatar
Ian Lynagh committed
486
        where
487
          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
488 489 490
                        -- See Note [CONLIKE pragma] in BasicTypes
                        -- The definition of is_exp should match that in
                        -- OccurAnal.occAnalApp
491

Peter Wortmann's avatar
Peter Wortmann committed
492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
    go n_val_args env (Tick t rhs)
        -- We want to be able to float bindings past this
        -- tick. Non-scoping ticks don't care.
        | tickishScoped t == NoScope
        = do { (is_exp, env', rhs') <- go n_val_args env rhs
             ; return (is_exp, env', Tick t rhs') }
        -- On the other hand, for scoping ticks we need to be able to
        -- copy them on the floats, which in turn is only allowed if
        -- we can obtain non-counting ticks.
        | not (tickishCounts t) || tickishCanSplit t
        = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs
             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
                   floats' = seFloats $ env `addFloats` mapFloats env' tickIt
             ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') }

Ian Lynagh's avatar
Ian Lynagh committed
507
    go _ env other
Ian Lynagh's avatar
Ian Lynagh committed
508
        = return (False, env, other)
509

Austin Seipp's avatar
Austin Seipp committed
510
{-
511 512 513
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
Ian Lynagh's avatar
Ian Lynagh committed
514
        x = e `cast` co
515
we'd like to transform it to
Ian Lynagh's avatar
Ian Lynagh committed
516 517
        x' = e
        x = x `cast` co         -- A trivial binding
518
There's a chance that e will be a constructor application or function, or something
519
like that, so moving the coercion to the usage site may well cancel the coercions
520 521 522 523 524 525 526 527 528 529 530
and lead to further optimisation.  Example:

     data family T a :: *
     data instance T Int = T Int

     foo :: Int -> Int -> Int
     foo m n = ...
        where
          x = T m
          go 0 = 0
          go n = case x of { T m -> go (n-m) }
Ian Lynagh's avatar
Ian Lynagh committed
531
                -- This case should optimise
532

533 534 535 536
Note [Preserve strictness when floating coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the Note [Float coercions] transformation, keep the strictness info.
Eg
537
        f = e `cast` co    -- f has strictness SSL
538
When we transform to
539
        f' = e             -- f' also has strictness SSL
540 541 542 543
        f = f' `cast` co   -- f still has strictness SSL

Its not wrong to drop it on the floor, but better to keep it.

544 545
Note [Float coercions (unlifted)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ian Lynagh's avatar
Ian Lynagh committed
546
BUT don't do [Float coercions] if 'e' has an unlifted type.
547 548
This *can* happen:

Ian Lynagh's avatar
Ian Lynagh committed
549 550
     foo :: Int = (error (# Int,Int #) "urk")
                  `cast` CoUnsafe (# Int,Int #) Int
551 552 553

If do the makeTrivial thing to the error call, we'll get
    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
Ian Lynagh's avatar
Ian Lynagh committed
554
But 'v' isn't in scope!
555 556

These strange casts can happen as a result of case-of-case
Ian Lynagh's avatar
Ian Lynagh committed
557 558
        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
                (# p,q #) -> p+q
Austin Seipp's avatar
Austin Seipp committed
559
-}
560

561
makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
562 563 564
makeTrivialArg env (ValArg e) = do
    { (env', e') <- makeTrivial NotTopLevel env (fsLit "arg") e
    ; return (env', ValArg e') }
565
makeTrivialArg env arg        = return (env, arg)  -- CastBy, TyArg
566

567 568 569
makeTrivial :: TopLevelFlag -> SimplEnv
            -> FastString  -- ^ a "friendly name" to build the new binder from
            -> OutExpr -> SimplM (SimplEnv, OutExpr)
570
-- Binds the expression to a variable, if it's not trivial, returning the variable
571 572
makeTrivial top_lvl env context expr =
    makeTrivialWithInfo top_lvl env context vanillaIdInfo expr
573

574 575 576 577
makeTrivialWithInfo :: TopLevelFlag -> SimplEnv
                    -> FastString
                    -- ^ a "friendly name" to build the new binder from
                    -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
578 579
-- Propagate strictness and demand info to the new binder
-- Note [Preserve strictness when floating coercions]
580
-- Returned SimplEnv has same substitution as incoming one
581
makeTrivialWithInfo top_lvl env context info expr
582 583 584
  | exprIsTrivial expr                          -- Already trivial
  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                --   See Note [Cannot trivialise]
585
  = return (env, expr)
Ian Lynagh's avatar
Ian Lynagh committed
586
  | otherwise           -- See Note [Take care] below
587
  = do  { uniq <- getUniqueM
588
        ; let name = mkSystemVarName uniq context
589
              var = mkLocalIdOrCoVarWithInfo name expr_ty info
590
        ; env'  <- completeNonRecX top_lvl env False var var expr
591
        ; expr' <- simplVar env' var
592
        ; return (env', expr') }
593 594 595 596 597 598 599 600 601
        -- The simplVar is needed becase we're constructing a new binding
        --     a = rhs
        -- And if rhs is of form (rhs1 |> co), then we might get
        --     a1 = rhs1
        --     a = a1 |> co
        -- and now a's RHS is trivial and can be substituted out, and that
        -- is what completeNonRecX will do
        -- To put it another way, it's as if we'd simplified
        --    let var = e in var
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
602 603 604 605
  where
    expr_ty = exprType expr

bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
606
-- True iff we can have a binding of this expression at this level
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
607 608
-- Precondition: the type is the type of the expression
bindingOk top_lvl _ expr_ty
609
  | isTopLevel top_lvl = not (isUnliftedType expr_ty)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
610
  | otherwise          = True
611

Austin Seipp's avatar
Austin Seipp committed
612
{-
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
613 614 615 616
Note [Cannot trivialise]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider tih
   f :: Int -> Addr#
617

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633
   foo :: Bar
   foo = Bar (f 3)

Then we can't ANF-ise foo, even though we'd like to, because
we can't make a top-level binding for the Addr# (f 3). And if
so we don't want to turn it into
   foo = let x = f 3 in Bar x
because we'll just end up inlining x back, and that makes the
simplifier loop.  Better not to ANF-ise it at all.

A case in point is literal strings (a MachStr is not regarded as
trivial):

   foo = Ptr "blob"#

We don't want to ANF-ise this.
634

Austin Seipp's avatar
Austin Seipp committed
635 636
************************************************************************
*                                                                      *
637
\subsection{Completing a lazy binding}
Austin Seipp's avatar
Austin Seipp committed
638 639
*                                                                      *
************************************************************************
640

641 642 643 644 645
completeBind
  * deals only with Ids, not TyVars
  * takes an already-simplified binder and RHS
  * is used for both recursive and non-recursive bindings
  * is used for both top-level and non-top-level bindings
646 647 648 649 650 651 652 653

It does the following:
  - tries discarding a dead binding
  - tries PostInlineUnconditionally
  - add unfolding [this is the only place we add an unfolding]
  - add arity

It does *not* attempt to do let-to-case.  Why?  Because it is used for
Ian Lynagh's avatar
Ian Lynagh committed
654
  - top-level bindings (when let-to-case is impossible)
655
  - many situations where the "rhs" is known to be a WHNF
Ian Lynagh's avatar
Ian Lynagh committed
656
                (so let-to-case is inappropriate).
657

658
Nor does it do the atomic-argument thing
Austin Seipp's avatar
Austin Seipp committed
659
-}
660 661

completeBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
662 663 664 665 666 667 668
             -> TopLevelFlag            -- Flag stuck into unfolding
             -> InId                    -- Old binder
             -> OutId -> OutExpr        -- New binder and RHS
             -> SimplM SimplEnv
-- completeBind may choose to do its work
--      * by extending the substitution (e.g. let x = y in ...)
--      * or by adding to the floats in the envt
669 670
--
-- Precondition: rhs obeys the let/app invariant
671
completeBind env top_lvl old_bndr new_bndr new_rhs
672 673
 | isCoVar old_bndr
 = case new_rhs of
674
     Coercion co -> return (extendCvSubst env old_bndr co)
675 676 677
     _           -> return (addNonRec env new_bndr new_rhs)

 | otherwise
678 679
 = ASSERT( isId new_bndr )
   do { let old_info = idInfo old_bndr
680 681
            old_unf  = unfoldingInfo old_info
            occ_info = occInfo old_info
682

683
        -- Do eta-expansion on the RHS of the binding
684
        -- See Note [Eta-expanding at let bindings] in SimplUtils
685
      ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
686

687
        -- Simplify the unfolding
688
      ; new_unfolding <- simplLetUnfolding env top_lvl old_bndr final_rhs old_unf
689

690 691
      ; dflags <- getDynFlags
      ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info
692 693
                                     final_rhs new_unfolding

694 695 696 697 698 699
                        -- Inline and discard the binding
        then do  { tick (PostInlineUnconditionally old_bndr)
                 ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
                -- Use the substitution to make quite, quite sure that the
                -- substitution will happen, since we are going to discard the binding
        else
700
   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
701

702
              -- Unfolding info: Note [Setting the new unfolding]
703
            info2 = info1 `setUnfoldingInfo` new_unfolding
704

705
              -- Demand info: Note [Setting the demand info]
706 707 708 709 710 711
              --
              -- We also have to nuke demand info if for some reason
              -- eta-expansion *reduces* the arity of the binding to less
              -- than that of the strictness sig. This can happen: see Note [Arity decrease].
            info3 | isEvaldUnfolding new_unfolding
                    || (case strictnessInfo info2 of
712
                          StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
713 714 715
                  = zapDemandInfo info2 `orElse` info2
                  | otherwise
                  = info2
716 717

            final_id = new_bndr `setIdInfo` info3
718

719
      ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
720
        return (addNonRec env final_id final_rhs) } }
721
                -- The addNonRec adds it to the in-scope set too
722 723 724

------------------------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
725 726 727 728
-- Add a new binding to the environment, complete with its unfolding
-- but *do not* do postInlineUnconditionally, because we have already
-- processed some of the scope of the binding
-- We still want the unfolding though.  Consider
729 730 731
--      let
--            x = /\a. let y = ... in Just y
--      in body
732
-- Then we float the y-binding out (via abstractFloats and addPolyBind)
733
-- but 'x' may well then be inlined in 'body' in which case we'd like the
734
-- opportunity to inline 'y' too.
735 736
--
-- INVARIANT: the arity is correct on the incoming binders
737 738

addPolyBind top_lvl env (NonRec poly_id rhs)
739
  = do  { unfolding <- simplLetUnfolding env top_lvl poly_id rhs noUnfolding
740 741
                        -- Assumes that poly_id did not have an INLINE prag
                        -- which is perhaps wrong.  ToDo: think about this
742 743
        ; let final_id = setIdInfo poly_id $
                         idInfo poly_id `setUnfoldingInfo` unfolding
744

745
        ; return (addNonRec env final_id rhs) }
746

747
addPolyBind _ env bind@(Rec _)
748
  = return (extendFloats env bind)
749 750 751
        -- Hack: letrecs are more awkward, so we extend "by steam"
        -- without adding unfoldings etc.  At worst this leads to
        -- more simplifier iterations
752

753 754
{- Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~~~~
755
Generally speaking the arity of a binding should not decrease.  But it *can*
Gabor Greif's avatar
typos  
Gabor Greif committed
756
legitimately happen because of RULES.  Eg
757
        f = g Int
758
where g has arity 2, will have arity 2.  But if there's a rewrite rule
759
        g Int --> h
760 761 762 763
where h has arity 1, then f's arity will decrease.  Here's a real-life example,
which is in the output of Specialise:

     Rec {
764 765
        $dm {Arity 2} = \d.\x. op d
        {-# RULES forall d. $dm Int d = $s$dm #-}
766

767 768 769 770
        dInt = MkD .... opInt ...
        opInt {Arity 1} = $dm dInt

        $s$dm {Arity 0} = \x. op dInt }
771 772 773 774

Here opInt has arity 1; but when we apply the rule its arity drops to 0.
That's why Specialise goes to a little trouble to pin the right arity
on specialised functions too.
775

776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791
Note [Setting the demand info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the unfolding is a value, the demand info may
go pear-shaped, so we nuke it.  Example:
     let x = (a,b) in
     case x of (p,q) -> h p q x
Here x is certainly demanded. But after we've nuked
the case, we'll get just
     let x = (a,b) in h a b x
and now x is not demanded (I'm assuming h is lazy)
This really happens.  Similarly
     let f = \x -> e in ...f..f...
After inlining f at some of its call sites the original binding may
(for example) be no longer strictly demanded.
The solution here is a bit ad hoc...

792

Austin Seipp's avatar
Austin Seipp committed
793 794
************************************************************************
*                                                                      *
795
\subsection[Simplify-simplExpr]{The main function: simplExpr}
Austin Seipp's avatar
Austin Seipp committed
796 797
*                                                                      *
************************************************************************
798

799 800 801 802 803 804
The reason for this OutExprStuff stuff is that we want to float *after*
simplifying a RHS, not before.  If we do so naively we get quadratic
behaviour as things float out.

To see why it's important to do it after, consider this (real) example:

Ian Lynagh's avatar
Ian Lynagh committed
805 806
        let t = f x
        in fst t
807
==>
Ian Lynagh's avatar
Ian Lynagh committed
808 809 810 811
        let t = let a = e1
                    b = e2
                in (a,b)
        in fst t
812
==>
Ian Lynagh's avatar
Ian Lynagh committed
813 814 815 816 817
        let a = e1
            b = e2
            t = (a,b)
        in
        a       -- Can't inline a this round, cos it appears twice
818
==>
Ian Lynagh's avatar
Ian Lynagh committed
819
        e1
820 821 822 823

Each of the ==> steps is a round of simplification.  We'd save a
whole round if we float first.  This can cascade.  Consider

Ian Lynagh's avatar
Ian Lynagh committed
824 825
        let f = g d
        in \x -> ...f...
826
==>
Ian Lynagh's avatar
Ian Lynagh committed
827 828
        let f = let d1 = ..d.. in \y -> e
        in \x -> ...f...
829
==>
Ian Lynagh's avatar
Ian Lynagh committed
830 831
        let d1 = ..d..
        in \x -> ...(\y ->e)...
832