Simplify.hs 121 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 29
import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
                        , 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 CoreSubst        ( pushCoTyArg, pushCoValArg )
39
--import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
40
import Rules            ( mkRuleInfo, lookupRule, getRules )
41
import TysPrim          ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
42
import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
43
import MonadUtils       ( foldlM, mapAccumLM, liftIO )
44
import Maybes           ( orElse )
45
--import Unique           ( hasKey ) -- temporalily commented out. See #8326
ian@well-typed.com's avatar
ian@well-typed.com committed
46
import Control.Monad
47
import Outputable
48
import FastString
49
import Pair
50
import Util
51
import ErrUtils
52

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


58
-----------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
59
        *** IMPORTANT NOTE ***
60 61 62 63 64 65
-----------------------------------------
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.


66
-----------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
67
        *** IMPORTANT NOTE ***
68 69 70 71 72 73 74 75 76 77
-----------------------------------------
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
78
        ORGANISATION OF FUNCTIONS
79 80 81 82 83 84
-----------------------------------------
simplTopBinds
  - simplify all top-level binders
  - for NonRec, call simplRecOrTopPair
  - for Rec,    call simplRecBind

Ian Lynagh's avatar
Ian Lynagh committed
85 86 87

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

Ian Lynagh's avatar
Ian Lynagh committed
91 92
        ------------------------------
simplRecBind    [binders already simplfied]
93 94 95 96
  - 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
97 98
            top-level non-recursive bindings
  Returns:
99 100 101 102 103
  - check for PreInlineUnconditionally
  - simplLazyBind

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

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

Ian Lynagh's avatar
Ian Lynagh committed
118
simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
119 120 121 122
  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
123 124 125

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


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

Ian Lynagh's avatar
Ian Lynagh committed
146 147
completeBind:   [given a simplified RHS]
        [used for both rec and non-rec bindings, top level and not]
148 149 150 151 152 153 154 155
  - 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
156 157 158
In many ways we want to treat
        (a) the right hand side of a let(rec), and
        (b) a function argument
159 160 161
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
162 163 164

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

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
169 170
        f (let { a = g x; b = h x } in (a,b))
        g (\y. + x y)
171 172 173

On the other hand if we see the let-defns

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

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

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
184
        r = let x = e in (x,x)
185 186 187 188 189 190 191 192 193 194 195 196 197 198

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
199
        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
200 201 202 203 204

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.
205 206


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

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

Ian Lynagh's avatar
Ian Lynagh committed
216
simplTopBinds env0 binds0
Ian Lynagh's avatar
Ian Lynagh committed
217 218 219 220
  = 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.
221
                -- See note [Glomming] in OccurAnal.
Ian Lynagh's avatar
Ian Lynagh committed
222
        ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
223
        ; env2 <- simpl_binds env1 binds0
Ian Lynagh's avatar
Ian Lynagh committed
224
        ; freeTick SimplifierDone
225
        ; return env2 }
226
  where
Ian Lynagh's avatar
Ian Lynagh committed
227 228 229 230
        -- 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.
        --
231 232 233 234
    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
235

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

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

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

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

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

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

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

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

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

286
simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
287 288 289 290
  = do { dflags <- getDynFlags
       ; trace_bind dflags $
           if preInlineUnconditionally dflags env top_lvl old_bndr rhs
                    -- Check for unconditional inline
291 292
           then do tick (PreInlineUnconditionally old_bndr)
                   return (extendIdSubst env old_bndr (mkContEx env rhs))
293 294 295 296 297 298 299 300 301
           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
302

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

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

    2. It assumes that the binder type is lifted.

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

simplLazyBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
320 321 322 323 324
              -> 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
325
-- Precondition: rhs obeys the let/app invariant
326
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
327 328
  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
    do  { let   rhs_env     = rhs_se `setInScope` env
329 330 331 332 333 334 335 336 337 338
                (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
339
                        -- Do not do the "abstract tyyvar" thing if there's
Gabor Greif's avatar
typos  
Gabor Greif committed
340
                        -- a lambda inside, because it defeats eta-reduction
341
                        --    f = /\a. \x. g a x
Peter Wortmann's avatar
Peter Wortmann committed
342
                        -- should eta-reduce.
343

344

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

348
        -- Simplify the RHS
349 350
        ; 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
351
        -- ANF-ise a constructor or PAP rhs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
352
        ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
Ian Lynagh's avatar
Ian Lynagh committed
353 354 355

        ; (env', rhs')
            <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
356
                then                            -- No floating, revert to body1
357
                     do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) rhs_cont
Ian Lynagh's avatar
Ian Lynagh committed
358 359 360 361 362 363 364 365 366
                        ; 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
367
                        ; rhs' <- mkLam env tvs' body3 rhs_cont
368
                        ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
369
                        ; return (env', rhs') }
Ian Lynagh's avatar
Ian Lynagh committed
370 371

        ; completeBind env' top_lvl bndr bndr1 rhs' }
372

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

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

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

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

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
405 406
completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
  = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
407
        ; (env2, rhs2) <-
408
                if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
Ian Lynagh's avatar
Ian Lynagh committed
409 410 411 412
                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 }
413

Austin Seipp's avatar
Austin Seipp committed
414
{-
415 416
{- 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
417
   In the cases described by the folowing commment, postInlineUnconditionally will
418
   catch many of the relevant cases.
Ian Lynagh's avatar
Ian Lynagh committed
419 420 421 422 423 424 425 426
        -- 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.
427

428
   Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
Ian Lynagh's avatar
Ian Lynagh committed
429 430 431 432 433 434
        -- 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.
435

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

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

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

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

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

Peter Wortmann's avatar
Peter Wortmann committed
493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
    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
508
    go _ env other
Ian Lynagh's avatar
Ian Lynagh committed
509
        = return (False, env, other)
510

Austin Seipp's avatar
Austin Seipp committed
511
{-
512 513 514
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
Ian Lynagh's avatar
Ian Lynagh committed
515
        x = e `cast` co
516
we'd like to transform it to
Ian Lynagh's avatar
Ian Lynagh committed
517 518
        x' = e
        x = x `cast` co         -- A trivial binding
519
There's a chance that e will be a constructor application or function, or something
520
like that, so moving the coercion to the usage site may well cancel the coercions
521 522 523 524 525 526 527 528 529 530 531
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
532
                -- This case should optimise
533

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

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

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

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

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
555
But 'v' isn't in scope!
556 557

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

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

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

575 576 577 578
makeTrivialWithInfo :: TopLevelFlag -> SimplEnv
                    -> FastString
                    -- ^ a "friendly name" to build the new binder from
                    -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
579 580
-- Propagate strictness and demand info to the new binder
-- Note [Preserve strictness when floating coercions]
581
-- Returned SimplEnv has same substitution as incoming one
582
makeTrivialWithInfo top_lvl env context info expr
583 584 585
  | exprIsTrivial expr                          -- Already trivial
  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                --   See Note [Cannot trivialise]
586
  = return (env, expr)
Ian Lynagh's avatar
Ian Lynagh committed
587
  | otherwise           -- See Note [Take care] below
588
  = do  { uniq <- getUniqueM
589
        ; let name = mkSystemVarName uniq context
590
              var = mkLocalIdOrCoVarWithInfo name expr_ty info
591
        ; env'  <- completeNonRecX top_lvl env False var var expr
592
        ; expr' <- simplVar env' var
593
        ; return (env', expr') }
Gabor Greif's avatar
Gabor Greif committed
594
        -- The simplVar is needed because we're constructing a new binding
595 596 597 598 599 600 601 602
        --     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
603 604 605 606
  where
    expr_ty = exprType expr

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

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634
   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.
635

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

642 643 644 645 646
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
647 648 649 650 651 652 653 654

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
655
  - top-level bindings (when let-to-case is impossible)
656
  - many situations where the "rhs" is known to be a WHNF
Ian Lynagh's avatar
Ian Lynagh committed
657
                (so let-to-case is inappropriate).
658

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

completeBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
663 664 665 666 667 668 669
             -> 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
670 671
--
-- Precondition: rhs obeys the let/app invariant
672
completeBind env top_lvl old_bndr new_bndr new_rhs
673 674
 | isCoVar old_bndr
 = case new_rhs of
675
     Coercion co -> return (extendCvSubst env old_bndr co)
676 677 678
     _           -> return (addNonRec env new_bndr new_rhs)

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

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

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

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

695 696 697 698 699 700
                        -- 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
701
   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
702

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

706
              -- Demand info: Note [Setting the demand info]
707 708 709 710 711 712
              --
              -- 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
713
                          StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
714 715 716
                  = zapDemandInfo info2 `orElse` info2
                  | otherwise
                  = info2
717 718

            final_id = new_bndr `setIdInfo` info3
719

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

------------------------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
726 727 728 729
-- 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
730 731 732
--      let
--            x = /\a. let y = ... in Just y
--      in body
733
-- Then we float the y-binding out (via abstractFloats and addPolyBind)
734
-- but 'x' may well then be inlined in 'body' in which case we'd like the
735
-- opportunity to inline 'y' too.
736 737
--
-- INVARIANT: the arity is correct on the incoming binders
738 739

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

746
        ; return (addNonRec env final_id rhs) }
747

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

754 755
{- Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~~~~
756
Generally speaking the arity of a binding should not decrease.  But it *can*
Gabor Greif's avatar
typos  
Gabor Greif committed
757
legitimately happen because of RULES.  Eg
758
        f = g Int
759
where g has arity 2, will have arity 2.  But if there's a rewrite rule
760
        g Int --> h
761 762 763 764
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 {
765 766
        $dm {Arity 2} = \d.\x. op d
        {-# RULES forall d. $dm Int d = $s$dm #-}
767

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

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

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.
776

777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792
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...

793

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

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

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
825 826
        let f = g d
        in \x -> ...f...
827
==>
Ian Lynagh's avatar
Ian Lynagh committed
828 829
        let f = let d1 = ..d.. in \y -> e
        in \x -> ...f...
830
==>
Ian Lynagh's avatar
Ian Lynagh committed
831 832
        let d1 = ..d..
        in \x -> ...(\y ->e)...
simonpj's avatar