Simplify.lhs 108 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1993-1998
3
4
5
6
%
\section[Simplify]{The main module of the simplifier}

\begin{code}
7
module Simplify ( simplTopBinds, simplExpr ) where
8

9
#include "HsVersions.h"
10

simonpj@microsoft.com's avatar
Wibble    
simonpj@microsoft.com committed
11
import DynFlags
12
import SimplMonad
13
import Type hiding      ( substTy, extendTvSubst, substTyVar )
Ian Lynagh's avatar
Ian Lynagh committed
14
import SimplEnv
15
import SimplUtils
16
17
import FamInstEnv       ( FamInstEnv )
import Literal          ( litIsLifted )
18
import Id
19
20
import MkId             ( seqId, realWorldPrimId )
import MkCore           ( mkImpossibleExpr, castBottomExpr )
21
import IdInfo
22
import Name             ( mkSystemVarName, isExternalName )
23
import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
24
import OptCoercion      ( optCoercion )
Ian Lynagh's avatar
Ian Lynagh committed
25
import FamInstEnv       ( topNormaliseType )
26
import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
27
import CoreMonad        ( Tick(..), SimplifierMode(..) )
28
import CoreSyn
29
import Demand           ( isStrictDmd, StrictSig(..), dmdTypeDepth )
Ian Lynagh's avatar
Ian Lynagh committed
30
import PprCore          ( pprParendExpr, pprCoreExpr )
31
import CoreUnfold
32
import CoreUtils
33
import qualified CoreSubst
34
import CoreArity
35
import Rules            ( lookupRule, getRules )
36
import BasicTypes       ( isMarkedStrict, Arity )
Ian Lynagh's avatar
Ian Lynagh committed
37
import TysPrim          ( realWorldStatePrimTy )
38
import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
39
import MonadUtils       ( foldlM, mapAccumLM, liftIO )
40
import Maybes           ( orElse, isNothing )
Ian Lynagh's avatar
Ian Lynagh committed
41
import Data.List        ( mapAccumL )
42
import Outputable
43
import FastString
44
import Pair
45
import Util
46
import ErrUtils
47
48
49
\end{code}


50
51
The guts of the simplifier is in this module, but the driver loop for
the simplifier is in SimplCore.lhs.
52
53


54
-----------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
55
        *** IMPORTANT NOTE ***
56
57
58
59
60
61
-----------------------------------------
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.


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

Ian Lynagh's avatar
Ian Lynagh committed
81
82
83

        ------------------------------
simplExpr (applied lambda)      ==> simplNonRecBind
84
85
86
simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind

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

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

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

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

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


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

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

        f (g x, h x)
        g (+ x)
161
162
163
164

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
165
166
        f (let { a = g x; b = h x } in (a,b))
        g (\y. + x y)
167
168
169

On the other hand if we see the let-defns

Ian Lynagh's avatar
Ian Lynagh committed
170
171
        p = (g x, h x)
        q = + x
172
173

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

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
180
        r = let x = e in (x,x)
181
182
183
184
185
186
187
188
189
190
191
192
193
194

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
195
        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
196
197
198
199
200

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.
201
202


203
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
204
%*                                                                      *
205
\subsection{Bindings}
Ian Lynagh's avatar
Ian Lynagh committed
206
%*                                                                      *
207
208
209
%************************************************************************

\begin{code}
210
simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
211

Ian Lynagh's avatar
Ian Lynagh committed
212
simplTopBinds env0 binds0
Ian Lynagh's avatar
Ian Lynagh committed
213
214
215
216
  = 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.
217
                -- See note [Glomming] in OccurAnal.
Ian Lynagh's avatar
Ian Lynagh committed
218
        ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
219
        ; dflags <- getDynFlags
220
        ; let dump_flag = dopt Opt_D_verbose_core2core dflags
Ian Lynagh's avatar
Ian Lynagh committed
221
        ; env2 <- simpl_binds dump_flag env1 binds0
Ian Lynagh's avatar
Ian Lynagh committed
222
        ; freeTick SimplifierDone
223
        ; return env2 }
224
  where
Ian Lynagh's avatar
Ian Lynagh committed
225
226
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.
        --
        -- The dump-flag emits a trace for each top-level binding, which
        -- helps to locate the tracing for inlining and rule firing
231
    simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
232
233
    simpl_binds _    env []           = return env
    simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
Ian Lynagh's avatar
Ian Lynagh committed
234
235
                                                     simpl_bind env bind
                                           ; simpl_binds dump env' binds }
236

Ian Lynagh's avatar
Ian Lynagh committed
237
238
    trace_bind True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
    trace_bind False _    = \x -> x
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
239

240
    simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
241
    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
Ian Lynagh's avatar
Ian Lynagh committed
242
243
        where
          (env', b') = addBndrRules env b (lookupRecBndr env b)
244
245
246
247
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
248
%*                                                                      *
249
\subsection{Lazy bindings}
Ian Lynagh's avatar
Ian Lynagh committed
250
%*                                                                      *
251
252
253
%************************************************************************

simplRecBind is used for
Ian Lynagh's avatar
Ian Lynagh committed
254
        * recursive bindings only
255
256
257

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

273
    go env [] = return env
Ian Lynagh's avatar
Ian Lynagh committed
274

275
    go env ((old_bndr, new_bndr, rhs) : pairs)
276
        = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
Ian Lynagh's avatar
Ian Lynagh committed
277
             ; go env' pairs }
278
279
\end{code}

280
simplOrTopPair is used for
Ian Lynagh's avatar
Ian Lynagh committed
281
282
        * recursive bindings (whether top level or not)
        * top-level non-recursive bindings
283
284
285
286
287

It assumes the binder has already been simplified, but not its IdInfo.

\begin{code}
simplRecOrTopPair :: SimplEnv
288
                  -> TopLevelFlag -> RecFlag
Ian Lynagh's avatar
Ian Lynagh committed
289
290
                  -> InId -> OutBndr -> InExpr  -- Binder and rhs
                  -> SimplM SimplEnv    -- Returns an env that includes the binding
291

292
simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
Ian Lynagh's avatar
Ian Lynagh committed
293
294
295
  | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
  = do  { tick (PreInlineUnconditionally old_bndr)
        ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
296
297

  | otherwise
298
  = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
299
300
301
302
\end{code}


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

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

    2. It assumes that the binder type is lifted.

    3. It does not check for pre-inline-unconditionallly;
       that should have been done already.

\begin{code}
simplLazyBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
318
319
320
321
322
              -> 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
323

324
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
325
326
  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
    do  { let   rhs_env     = rhs_se `setInScope` env
327
328
329
330
331
332
333
334
335
                (tvs, body) = case collectTyBinders rhs of
                                (tvs, body) | not_lam body -> (tvs,body)
                                            | otherwise    -> ([], rhs)
                not_lam (Lam _ _) = False
                not_lam _         = True
                        -- Do not do the "abstract tyyvar" thing if there's
                        -- a lambda inside, becuase it defeats eta-reduction
                        --    f = /\a. \x. g a x
                        -- should eta-reduce
336

337

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

341
        -- Simplify the RHS
342
343
        ; let   body_out_ty :: OutType
                body_out_ty = substTy body_env (exprType body)
344
        ; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty)
Ian Lynagh's avatar
Ian Lynagh committed
345
        -- ANF-ise a constructor or PAP rhs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
346
        ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
Ian Lynagh's avatar
Ian Lynagh committed
347
348
349

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

        ; completeBind env' top_lvl bndr bndr1 rhs' }
366
\end{code}
367

Ian Lynagh's avatar
Ian Lynagh committed
368
A specialised variant of simplNonRec used when the RHS is already simplified,
369
370
371
372
notably in knownCon.  It uses case-binding where necessary.

\begin{code}
simplNonRecX :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
373
374
375
             -> InId            -- Old binder
             -> OutExpr         -- Simplified RHS
             -> SimplM SimplEnv
376
377

simplNonRecX env bndr new_rhs
378
379
380
381
  | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
  = return env          --               Here c is dead, and we avoid creating
                        --               the binding c = (a,b)
  | Coercion co <- new_rhs
382
  = return (extendCvSubst env bndr co)
383
  | otherwise           --               the binding b = (a,b)
Ian Lynagh's avatar
Ian Lynagh committed
384
  = do  { (env', bndr') <- simplBinder env bndr
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
385
        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
386
                -- simplNonRecX is only used for NotTopLevel things
387

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
388
completeNonRecX :: TopLevelFlag -> SimplEnv
389
                -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
390
391
392
393
                -> InId                 -- Old binder
                -> OutId                -- New binder
                -> OutExpr              -- Simplified RHS
                -> SimplM SimplEnv
394

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
395
396
completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
  = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
397
        ; (env2, rhs2) <-
398
                if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
Ian Lynagh's avatar
Ian Lynagh committed
399
400
401
402
                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 }
403
404
405
406
\end{code}

{- 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
407
   In the cases described by the folowing commment, postInlineUnconditionally will
408
   catch many of the relevant cases.
Ian Lynagh's avatar
Ian Lynagh committed
409
410
411
412
413
414
415
416
        -- 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.
417

418
   Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
Ian Lynagh's avatar
Ian Lynagh committed
419
420
421
422
423
424
        -- 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.
425

426
427
428
429
  | preInlineUnconditionally env NotTopLevel bndr new_rhs
  = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
-}

430
----------------------------------
431
prepareRhs takes a putative RHS, checks whether it's a PAP or
Ian Lynagh's avatar
Ian Lynagh committed
432
constructor application and, if so, converts it to ANF, so that the
433
resulting thing can be inlined more easily.  Thus
Ian Lynagh's avatar
Ian Lynagh committed
434
        x = (f a, g b)
435
becomes
Ian Lynagh's avatar
Ian Lynagh committed
436
437
438
        t1 = f a
        t2 = g b
        x = (t1,t2)
439

440
We also want to deal well cases like this
Ian Lynagh's avatar
Ian Lynagh committed
441
        v = (f e1 `cast` co) e2
442
Here we want to make e1,e2 trivial and get
Ian Lynagh's avatar
Ian Lynagh committed
443
        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
444
445
That's what the 'go' loop in prepareRhs does

446
\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
447
prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
448
-- Adds new floats to the env iff that allows us to return a good RHS
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
449
prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
450
  | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
Ian Lynagh's avatar
Ian Lynagh committed
451
  , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
452
  = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
Ian Lynagh's avatar
Ian Lynagh committed
453
        ; return (env', Cast rhs' co) }
454
  where
455
456
    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
                                   `setDemandInfo`     demandInfo info
457
    info = idInfo id
458

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
459
prepareRhs top_lvl env0 _ rhs0
460
  = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
Ian Lynagh's avatar
Ian Lynagh committed
461
        ; return (env1, rhs1) }
462
  where
463
    go n_val_args env (Cast rhs co)
464
465
        = do { (is_exp, env', rhs') <- go n_val_args env rhs
             ; return (is_exp, env', Cast rhs' co) }
466
    go n_val_args env (App fun (Type ty))
467
468
        = do { (is_exp, env', rhs') <- go n_val_args env fun
             ; return (is_exp, env', App rhs' (Type ty)) }
469
    go n_val_args env (App fun arg)
470
471
        = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
             ; case is_exp of
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
472
                True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
Ian Lynagh's avatar
Ian Lynagh committed
473
474
                           ; return (True, env'', App fun' arg') }
                False -> return (False, env, App fun arg) }
475
    go n_val_args env (Var fun)
476
        = return (is_exp, env, Var fun)
Ian Lynagh's avatar
Ian Lynagh committed
477
        where
478
          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
479
480
481
                        -- See Note [CONLIKE pragma] in BasicTypes
                        -- The definition of is_exp should match that in
                        -- OccurAnal.occAnalApp
482

Ian Lynagh's avatar
Ian Lynagh committed
483
    go _ env other
Ian Lynagh's avatar
Ian Lynagh committed
484
        = return (False, env, other)
485
486
\end{code}

487

488
489
490
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
Ian Lynagh's avatar
Ian Lynagh committed
491
        x = e `cast` co
492
we'd like to transform it to
Ian Lynagh's avatar
Ian Lynagh committed
493
494
        x' = e
        x = x `cast` co         -- A trivial binding
495
496
497
498
499
500
501
502
503
504
505
506
507
There's a chance that e will be a constructor application or function, or something
like that, so moving the coerion to the usage site may well cancel the coersions
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
508
                -- This case should optimise
509

510
511
512
513
Note [Preserve strictness when floating coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the Note [Float coercions] transformation, keep the strictness info.
Eg
514
        f = e `cast` co    -- f has strictness SSL
515
When we transform to
516
        f' = e             -- f' also has strictness SSL
517
518
519
520
        f = f' `cast` co   -- f still has strictness SSL

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

521
522
Note [Float coercions (unlifted)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ian Lynagh's avatar
Ian Lynagh committed
523
BUT don't do [Float coercions] if 'e' has an unlifted type.
524
525
This *can* happen:

Ian Lynagh's avatar
Ian Lynagh committed
526
527
     foo :: Int = (error (# Int,Int #) "urk")
                  `cast` CoUnsafe (# Int,Int #) Int
528
529
530

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
531
But 'v' isn't in scope!
532
533

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

537
538

\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
539
makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
540
-- Binds the expression to a variable, if it's not trivial, returning the variable
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
541
makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
542

543
makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
544
                    -> OutExpr -> SimplM (SimplEnv, OutExpr)
545
546
-- Propagate strictness and demand info to the new binder
-- Note [Preserve strictness when floating coercions]
547
-- Returned SimplEnv has same substitution as incoming one
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
548
makeTrivialWithInfo top_lvl env info expr
549
550
551
  | exprIsTrivial expr                          -- Already trivial
  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                --   See Note [Cannot trivialise]
552
  = return (env, expr)
Ian Lynagh's avatar
Ian Lynagh committed
553
  | otherwise           -- See Note [Take care] below
554
555
  = do  { uniq <- getUniqueM
        ; let name = mkSystemVarName uniq (fsLit "a")
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
556
              var = mkLocalIdWithInfo name expr_ty info
557
        ; env'  <- completeNonRecX top_lvl env False var var expr
558
        ; expr' <- simplVar env' var
559
        ; return (env', expr') }
560
561
562
563
564
565
566
567
568
        -- 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
569
570
571
572
  where
    expr_ty = exprType expr

bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
573
-- True iff we can have a binding of this expression at this level
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
574
575
-- Precondition: the type is the type of the expression
bindingOk top_lvl _ expr_ty
576
  | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
577
  | otherwise          = True
578
\end{code}
579

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
580
581
582
583
Note [Cannot trivialise]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider tih
   f :: Int -> Addr#
584

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
   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.
601

602
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
603
%*                                                                      *
604
\subsection{Completing a lazy binding}
Ian Lynagh's avatar
Ian Lynagh committed
605
%*                                                                      *
606
607
%************************************************************************

608
609
610
611
612
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
613
614
615
616
617
618
619
620

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

625
626
Nor does it do the atomic-argument thing

627
\begin{code}
628
completeBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
629
630
631
632
633
634
635
             -> 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
636
637

completeBind env top_lvl old_bndr new_bndr new_rhs
638
639
640
641
642
643
 | isCoVar old_bndr
 = case new_rhs of
     Coercion co -> return (extendCvSubst env old_bndr co)
     _           -> return (addNonRec env new_bndr new_rhs)

 | otherwise
644
645
 = ASSERT( isId new_bndr )
   do { let old_info = idInfo old_bndr
646
647
            old_unf  = unfoldingInfo old_info
            occ_info = occInfo old_info
648

649
        -- Do eta-expansion on the RHS of the binding
650
651
        -- See Note [Eta-expanding at let bindings] in SimplUtils
      ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
652

653
        -- Simplify the unfolding
654
      ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
655

656
657
658
      ; if postInlineUnconditionally env top_lvl new_bndr occ_info
                                     final_rhs new_unfolding

659
660
661
662
663
664
                        -- 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
665
   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
666

667
              -- Unfolding info: Note [Setting the new unfolding]
668
            info2 = info1 `setUnfoldingInfo` new_unfolding
669

670
              -- Demand info: Note [Setting the demand info]
671
672
673
674
675
676
677
678
679
680
681
              --
              -- 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
                          Just (StrictSig dmd_ty) -> new_arity < dmdTypeDepth dmd_ty
                          Nothing                 -> False)
                  = zapDemandInfo info2 `orElse` info2
                  | otherwise
                  = info2
682
683

            final_id = new_bndr `setIdInfo` info3
684

685
      ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
686
        return (addNonRec env final_id final_rhs) } }
687
                -- The addNonRec adds it to the in-scope set too
688
689
690

------------------------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
691
692
693
694
-- 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
695
696
697
--      let
--            x = /\a. let y = ... in Just y
--      in body
698
-- Then we float the y-binding out (via abstractFloats and addPolyBind)
699
-- but 'x' may well then be inlined in 'body' in which case we'd like the
700
-- opportunity to inline 'y' too.
701
702
--
-- INVARIANT: the arity is correct on the incoming binders
703
704

addPolyBind top_lvl env (NonRec poly_id rhs)
705
  = do  { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
706
707
                        -- Assumes that poly_id did not have an INLINE prag
                        -- which is perhaps wrong.  ToDo: think about this
708
709
        ; let final_id = setIdInfo poly_id $
                         idInfo poly_id `setUnfoldingInfo` unfolding
710

711
        ; return (addNonRec env final_id rhs) }
712

713
addPolyBind _ env bind@(Rec _)
714
  = return (extendFloats env bind)
715
716
717
        -- Hack: letrecs are more awkward, so we extend "by steam"
        -- without adding unfoldings etc.  At worst this leads to
        -- more simplifier iterations
718
719
720

------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
721
722
               -> InId
               -> OutExpr
723
               -> Unfolding -> SimplM Unfolding
724
-- Note [Setting the new unfolding]
725
simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
726
  = return (DFunUnfolding ar con ops')
727
  where
728
    ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
729

730
simplUnfolding env top_lvl id _
731
    (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
732
                   , uf_src = src, uf_guidance = guide })
733
  | isStableSource src
734
735
  = do { expr' <- simplExpr rule_env expr
       ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
736
737
             is_top_lvl = isTopLevel top_lvl
       ; case guide of
738
739
           UnfWhen sat_ok _    -- Happens for INLINE things
              -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
740
741
742
743
744
                     -- Refresh the boring-ok flag, in case expr'
                     -- has got small. This happens, notably in the inlinings
                     -- for dfuns for single-method classes; see
                     -- Note [Single-method classes] in TcInstDcls.
                     -- A test case is Trac #4138
745
                 in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
746
                 -- See Note [Top-level flag on inline rules] in CoreUnfold
747
748
749
750
751

           _other              -- Happens for INLINABLE things
              -> let bottoming = isBottomingId id
                 in bottoming `seq` -- See Note [Force bottoming field]
                    return (mkUnfolding src' is_top_lvl bottoming expr')
752
753
754
755
                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
                -- unfolding, and we need to make sure the guidance is kept up
                -- to date with respect to any changes in the unfolding.
       }
756
  where
757
758
    act      = idInlineActivation id
    rule_env = updMode (updModeForInlineRules act) env
759
               -- See Note [Simplifying inside InlineRules] in SimplUtils
760

761
762
763
764
simplUnfolding _ top_lvl id new_rhs _
  = let bottoming = isBottomingId id
    in bottoming `seq`  -- See Note [Force bottoming field]
       return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
765
766
767
768
769
770
          -- We make an  unfolding *even for loop-breakers*.
          -- Reason: (a) It might be useful to know that they are WHNF
          --         (b) In TidyPgm we currently assume that, if we want to
          --             expose the unfolding then indeed we *have* an unfolding
          --             to expose.  (We could instead use the RHS, but currently
          --             we don't.)  The simple thing is always to have one.
771
\end{code}
772

773
774
775
776
777
Note [Force bottoming field]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to force bottoming, or the new unfolding holds
on to the old unfolding (which is part of the id).

778
779
Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~
780
Generally speaking the arity of a binding should not decrease.  But it *can*
781
legitimately happen becuase of RULES.  Eg
782
        f = g Int
783
where g has arity 2, will have arity 2.  But if there's a rewrite rule
784
        g Int --> h
785
786
787
788
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 {
789
790
        $dm {Arity 2} = \d.\x. op d
        {-# RULES forall d. $dm Int d = $s$dm #-}
791

792
793
794
795
        dInt = MkD .... opInt ...
        opInt {Arity 1} = $dm dInt

        $s$dm {Arity 0} = \x. op dInt }
796
797
798
799

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

801
802
803
Note [Setting the new unfolding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
804
  should do nothing at all, but simplifying gently might get rid of
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
  more crap.

* If not, we make an unfolding from the new RHS.  But *only* for
  non-loop-breakers. Making loop breakers not have an unfolding at all
  means that we can avoid tests in exprIsConApp, for example.  This is
  important: if exprIsConApp says 'yes' for a recursive thing, then we
  can get into an infinite loop

If there's an InlineRule on a loop breaker, we hang on to the inlining.
It's pretty dodgy, but the user did say 'INLINE'.  May need to revisit
this choice.

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

833

834
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
835
%*                                                                      *
836
\subsection[Simplify-simplExpr]{The main function: simplExpr}
Ian Lynagh's avatar
Ian Lynagh committed
837
%*                                                                      *
838
839
%************************************************************************

840
841
842
843
844
845
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
846
847
        let t = f x
        in fst t
848
==>
Ian Lynagh's avatar
Ian Lynagh committed
849
850
851
852
        let t = let a = e1
                    b = e2
                in (a,b)
        in fst t
853
==>
Ian Lynagh's avatar
Ian Lynagh committed
854
855
856
857
858
        let a = e1
            b = e2
            t = (a,b)
        in
        a       -- Can't inline a this round, cos it appears twice
859
==>
Ian Lynagh's avatar
Ian Lynagh committed
860
        e1
861
862
863
864

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
865
866
        let f = g d
        in \x -> ...f...
867
==>
Ian Lynagh's avatar
Ian Lynagh committed
868
869
        let f = let d1 = ..d.. in \y -> e
        in \x -> ...f...
870
==>
Ian Lynagh's avatar
Ian Lynagh committed
871
872
        let d1 = ..d..
        in \x -> ...(\y ->e)...
873

Ian Lynagh's avatar
Ian Lynagh committed
874
Only in this second round can the \y be applied, and it
875
876
877
might do the same again.


878
\begin{code}
879
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
880
881
882
883
simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
  where
    expr_out_ty :: OutType
    expr_out_ty = substTy env (exprType expr)
884

885
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
Ian Lynagh's avatar
Ian Lynagh committed
886
887
        -- Simplify an expression, given a continuation
simplExprC env expr cont
888
  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
Ian Lynagh's avatar
Ian Lynagh committed
889
890
891
892
    do  { (env', expr') <- simplExprF (zapFloats env) expr cont
        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
          -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
893
894
895
896
          return (wrapFloats env' expr') }

--------------------------------------------------
simplExprF :: SimplEnv -> InExpr -> SimplCont
Ian Lynagh's avatar
Ian Lynagh committed
897
           -> SimplM (SimplEnv, OutExpr)
898

Ian Lynagh's avatar
Ian Lynagh committed
899
simplExprF env e cont
900
  = {- pprTrace "simplExprF" (vcat
901
902
903
904
905
906
      [ ppr e
      , text "cont =" <+> ppr cont
      , text "inscope =" <+> ppr (seInScope env)
      , text "tvsubst =" <+> ppr (seTvSubst env)
      , text "idsubst =" <+> ppr (seIdSubst env)
      , text "cvsubst =" <+> ppr (seCvSubst env)
907
      {- , ppr (seFloats env) -}
908
      ]) $ -}
909
    simplExprF1 env e cont
Ian Lynagh's avatar
Ian Lynagh committed
910

911
simplExprF1 :: SimplEnv -> InExpr -> SimplCont
Ian Lynagh's avatar
Ian Lynagh committed
912
            -> SimplM (SimplEnv, OutExpr)
913
914
simplExprF1 env (Var v)        cont = simplIdF env v cont
simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
915
simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont
916
917
918
919
920
simplExprF1 env (Cast body co) cont = simplCast env body co cont
simplExprF1 env (Coercion co)  cont = simplCoercionF env co cont
simplExprF1 env (Type ty)      cont = ASSERT( contIsRhsOrArg cont )
                                      rebuild env (Type (substTy env ty)) cont
simplExprF1 env (App fun arg)  cont = simplExprF env fun $
Ian Lynagh's avatar
Ian Lynagh committed
921
                                      ApplyTo NoDup arg env cont
922

923
simplExprF1 env expr@(Lam {}) cont
924
  = simplLam env zapped_bndrs body cont
Ian Lynagh's avatar
Ian Lynagh committed
925
926
927
928
929
        -- The main issue here is under-saturated lambdas
        --   (\x1. \x2. e) arg1
        -- Here x1 might have "occurs-once" occ-info, because occ-info
        -- is computed assuming that a group of lambdas is applied
        -- all at once.  If there are too few args, we must zap the
930
        -- occ-info, UNLESS the remaining binders are one-shot
931
932
  where
    (bndrs, body) = collectBinders expr
933
934
935
936
937
938
939
    zapped_bndrs | need_to_zap = map zap bndrs
                 | otherwise   = bndrs

    need_to_zap = any zappable_bndr (drop n_args bndrs)
    n_args = countArgs cont
        -- NB: countArgs counts all the args (incl type args)
        -- and likewise drop counts all binders (incl type lambdas)
940

941
    zappable_bndr b = isId b && not (isOneShotBndr b)
942
943
    zap b | isTyVar b = b
          | otherwise = zapLamIdInfo b
944

945
simplExprF1 env (Case scrut bndr alts_ty alts) cont
946
  | sm_case_case (getMode env)
Ian Lynagh's avatar
Ian Lynagh committed
947
  =     -- Simplify the scrutinee with a Select continuation
948
    simplExprF env scrut (Select NoDup bndr alts env cont)
949

950
  | otherwise
Ian Lynagh's avatar
Ian Lynagh committed
951
952
  =     -- If case-of-case is off, simply simplify the case expression
        -- in a vanilla Stop context, and rebuild the result around it
953
    do  { case_expr' <- simplExprC env scrut
954
                             (Select NoDup bndr alts env (mkBoringStop alts_out_ty))
Ian Lynagh's avatar
Ian Lynagh committed
955
        ; rebuild env case_expr' cont }
956
957
  where
    alts_out_ty = substTy env alts_ty
958

959
simplExprF1 env (Let (Rec pairs) body) cont
Ian Lynagh's avatar
Ian Lynagh committed
960
  = do  { env' <- simplRecBndrs env (map fst pairs)
Ian Lynagh's avatar
Ian Lynagh committed
961
962
                -- NB: bndrs' don't have unfoldings or rules
                -- We add them as we go down
963

Ian Lynagh's avatar
Ian Lynagh committed
964
965
        ; env'' <- simplRecBind env' NotTopLevel pairs
        ; simplExprF env'' body cont }
966

967
simplExprF1 env (Let (NonRec bndr rhs) body) cont
968
  = simplNonRecE env bndr (rhs, env) ([], body) cont
969
970

---------------------------------
971
simplType :: SimplEnv -> InType -> SimplM OutType
Ian Lynagh's avatar
Ian Lynagh committed
972
        -- Kept monadic just so we can do the seqType
973
simplType env ty
974
  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
975
    seqType new_ty `seq` return new_ty
976
  where
977
    new_ty = substTy env ty
978
979

---------------------------------
980
981
simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
               -> SimplM (SimplEnv, OutExpr)
982
simplCoercionF env co cont
983
  = do { co' <- simplCoercion env co
984
       ; rebuild env (Coercion co') cont }
985

986
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion