Simplify.hs 116 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 ) 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, extendTvSubst, substTyVar )
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             ( mkSystemVarName, isExternalName )
25
import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
26
import OptCoercion      ( optCoercion )
27
import FamInstEnv       ( topNormaliseType_maybe )
28
29
30
import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
                        , isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG )
--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            ( 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
Ian Lynagh's avatar
Ian Lynagh committed
46
import Data.List        ( mapAccumL )
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
55
The guts of the simplifier is in this module, but the driver loop for
the simplifier is in SimplCore.lhs.
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
    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
Ian Lynagh's avatar
Ian Lynagh committed
238
239
        where
          (env', b') = addBndrRules env b (lookupRecBndr env b)
240

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

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

simplRecBind :: SimplEnv -> TopLevelFlag
Ian Lynagh's avatar
Ian Lynagh committed
253
254
             -> [(InId, InExpr)]
             -> SimplM SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
255
256
257
258
259
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
260
        -- _and_ updates env0 with the in-scope set from env1
261
  where
262
    add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
Ian Lynagh's avatar
Ian Lynagh committed
263
        -- Add the (substituted) rules to the binder
264
    add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
Ian Lynagh's avatar
Ian Lynagh committed
265
266
        where
          (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
267

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

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

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

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

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

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

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

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

    2. It assumes that the binder type is lifted.

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

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

342

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

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

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

        ; completeBind env' top_lvl bndr bndr1 rhs' }
370

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
509
{-
510
511
512
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
Ian Lynagh's avatar
Ian Lynagh committed
513
        x = e `cast` co
514
we'd like to transform it to
Ian Lynagh's avatar
Ian Lynagh committed
515
516
        x' = e
        x = x `cast` co         -- A trivial binding
517
518
519
520
521
522
523
524
525
526
527
528
529
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
530
                -- This case should optimise
531

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

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

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

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

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

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

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
565
makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
566
-- Binds the expression to a variable, if it's not trivial, returning the variable
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
567
makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
568

569
makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
570
                    -> OutExpr -> SimplM (SimplEnv, OutExpr)
571
572
-- Propagate strictness and demand info to the new binder
-- Note [Preserve strictness when floating coercions]
573
-- Returned SimplEnv has same substitution as incoming one
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
574
makeTrivialWithInfo top_lvl env info expr
575
576
577
  | exprIsTrivial expr                          -- Already trivial
  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                --   See Note [Cannot trivialise]
578
  = return (env, expr)
Ian Lynagh's avatar
Ian Lynagh committed
579
  | otherwise           -- See Note [Take care] below
580
581
  = do  { uniq <- getUniqueM
        ; let name = mkSystemVarName uniq (fsLit "a")
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
582
              var = mkLocalIdWithInfo name expr_ty info
583
        ; env'  <- completeNonRecX top_lvl env False var var expr
584
        ; expr' <- simplVar env' var
585
        ; return (env', expr') }
586
587
588
589
590
591
592
593
594
        -- 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
595
596
597
598
  where
    expr_ty = exprType expr

bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
599
-- True iff we can have a binding of this expression at this level
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
600
601
-- Precondition: the type is the type of the expression
bindingOk top_lvl _ expr_ty
602
  | isTopLevel top_lvl = not (isUnLiftedType expr_ty)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
603
  | otherwise          = True
604

Austin Seipp's avatar
Austin Seipp committed
605
{-
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
606
607
608
609
Note [Cannot trivialise]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider tih
   f :: Int -> Addr#
610

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
   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.
627

Austin Seipp's avatar
Austin Seipp committed
628
629
************************************************************************
*                                                                      *
630
\subsection{Completing a lazy binding}
Austin Seipp's avatar
Austin Seipp committed
631
632
*                                                                      *
************************************************************************
633

634
635
636
637
638
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
639
640
641
642
643
644
645
646

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

651
Nor does it do the atomic-argument thing
Austin Seipp's avatar
Austin Seipp committed
652
-}
653
654

completeBind :: SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
655
656
657
658
659
660
661
             -> 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
662
663
--
-- Precondition: rhs obeys the let/app invariant
664
completeBind env top_lvl old_bndr new_bndr new_rhs
665
666
667
668
669
670
 | isCoVar old_bndr
 = case new_rhs of
     Coercion co -> return (extendCvSubst env old_bndr co)
     _           -> return (addNonRec env new_bndr new_rhs)

 | otherwise
671
672
 = ASSERT( isId new_bndr )
   do { let old_info = idInfo old_bndr
673
674
            old_unf  = unfoldingInfo old_info
            occ_info = occInfo old_info
675

676
        -- Do eta-expansion on the RHS of the binding
677
        -- See Note [Eta-expanding at let bindings] in SimplUtils
678
      ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
679

680
        -- Simplify the unfolding
681
      ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
682

683
684
      ; dflags <- getDynFlags
      ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info
685
686
                                     final_rhs new_unfolding

687
688
689
690
691
692
                        -- 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
693
   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
694

695
              -- Unfolding info: Note [Setting the new unfolding]
696
            info2 = info1 `setUnfoldingInfo` new_unfolding
697

698
              -- Demand info: Note [Setting the demand info]
699
700
701
702
703
704
              --
              -- 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
705
                          StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
706
707
708
                  = zapDemandInfo info2 `orElse` info2
                  | otherwise
                  = info2
709
710

            final_id = new_bndr `setIdInfo` info3
711

712
      ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
713
        return (addNonRec env final_id final_rhs) } }
714
                -- The addNonRec adds it to the in-scope set too
715
716
717

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

addPolyBind top_lvl env (NonRec poly_id rhs)
732
  = do  { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
733
734
                        -- Assumes that poly_id did not have an INLINE prag
                        -- which is perhaps wrong.  ToDo: think about this
735
736
        ; let final_id = setIdInfo poly_id $
                         idInfo poly_id `setUnfoldingInfo` unfolding
737

738
        ; return (addNonRec env final_id rhs) }
739

740
addPolyBind _ env bind@(Rec _)
741
  = return (extendFloats env bind)
742
743
744
        -- Hack: letrecs are more awkward, so we extend "by steam"
        -- without adding unfoldings etc.  At worst this leads to
        -- more simplifier iterations
745
746
747

------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
748
749
               -> InId
               -> OutExpr
750
               -> Unfolding -> SimplM Unfolding
751
-- Note [Setting the new unfolding]
752
753
754
755
756
757
758
simplUnfolding env top_lvl id new_rhs unf
  = case unf of
      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
        -> do { (env', bndrs') <- simplBinders rule_env bndrs
              ; args' <- mapM (simplExpr env') args
              ; return (mkDFunUnfolding bndrs' con args') }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
759
      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
760
761
762
        | isStableSource src
        -> do { expr' <- simplExpr rule_env expr
              ; case guide of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
763
764
765
                  UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok }  -- Happens for INLINE things
                     -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
                                             , ug_boring_ok = inlineBoringOk expr' }
766
767
768
769
770
                        -- 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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
771
                        in return (mkCoreUnfolding src is_top_lvl expr' guide')
772
773
774
775
776
777
                            -- See Note [Top-level flag on inline rules] in CoreUnfold

                  _other              -- Happens for INLINABLE things
                     -> bottoming `seq` -- See Note [Force bottoming field]
                        do { dflags <- getDynFlags
                           ; return (mkUnfolding dflags src is_top_lvl bottoming expr') } }
778
779
780
                -- 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.
781
782
783
784
785
786
787
788
789
790

      _other -> bottoming `seq`  -- See Note [Force bottoming field]
                do { dflags <- getDynFlags
                   ; return (mkUnfolding dflags InlineRhs is_top_lvl bottoming new_rhs) }
                     -- 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.
791
  where
792
793
    bottoming = isBottomingId id
    is_top_lvl = isTopLevel top_lvl
794
    act      = idInlineActivation id
795
796
    rule_env = updMode (updModeForStableUnfoldings act) env
               -- See Note [Simplifying inside stable unfoldings] in SimplUtils
797

Austin Seipp's avatar
Austin Seipp committed
798
{-
799
800
801
802
803
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).

804
805
Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~
806
Generally speaking the arity of a binding should not decrease.  But it *can*
Gabor Greif's avatar
typos    
Gabor Greif committed
807
legitimately happen because of RULES.  Eg
808
        f = g Int
809
where g has arity 2, will have arity 2.  But if there's a rewrite rule
810
        g Int --> h
811
812
813
814
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 {
815
816
        $dm {Arity 2} = \d.\x. op d
        {-# RULES forall d. $dm Int d = $s$dm #-}
817

818
819
820
821
        dInt = MkD .... opInt ...
        opInt {Arity 1} = $dm dInt

        $s$dm {Arity 0} = \x. op dInt }
822
823
824
825

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

827
828
829
Note [Setting the new unfolding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
830
  should do nothing at all, but simplifying gently might get rid of
831
832
833
834
835
836
837
838
  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

839
840
841
If there's an stable unfolding on a loop breaker (which happens for
INLINEABLE), we hang on to the inlining.  It's pretty dodgy, but the
user did say 'INLINE'.  May need to revisit this choice.
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858

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

859

Austin Seipp's avatar
Austin Seipp committed
860
861
************************************************************************
*                                                                      *
862
\subsection[Simplify-simplExpr]{The main function: simplExpr}
Austin Seipp's avatar
Austin Seipp committed
863
864
*                                                                      *
************************************************************************
865

866
867
868
869
870
871
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
872
873
        let t = f x
        in fst t
874
==>
Ian Lynagh's avatar
Ian Lynagh committed
875
876
877
878
        let t = let a = e1
                    b = e2
                in (a,b)
        in fst t
879
==>
Ian Lynagh's avatar
Ian Lynagh committed
880
881
882
883
884
        let a = e1
            b = e2
            t = (a,b)
        in
        a       -- Can't inline a this round, cos it appears twice
885
==>
Ian Lynagh's avatar
Ian Lynagh committed
886
        e1
887
888
889
890

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
891
892
        let f = g d
        in \x -> ...f...
893
==>
Ian Lynagh's avatar
Ian Lynagh committed
894
895
        let f = let d1 = ..d.. in \y -> e
        in \x -> ...f...
896
==>
Ian Lynagh's avatar
Ian Lynagh committed
897
898
        let d1 = ..d..
        in \x -> ...(\y ->e)...
899

Ian Lynagh's avatar
Ian Lynagh committed
900
Only in this second round can the \y be applied, and it
901
might do the same again.
Austin Seipp's avatar
Austin Seipp committed
902
-}
903

904
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
905
906
907
908
simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
  where
    expr_out_ty :: OutType
    expr_out_ty = substTy env (exprType expr)
909

910
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
Ian Lynagh's avatar
Ian Lynagh committed
911
912
        -- Simplify an expression, given a continuation
simplExprC env expr cont
913
  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
Ian Lynagh's avatar
Ian Lynagh committed
914
915
916
917
    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')) $
918
919
920
921
          return (wrapFloats env' expr') }

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

Ian Lynagh's avatar
Ian Lynagh committed
924
simplExprF env e cont
925
  = {- pprTrace "simplExprF" (vcat
926
927
928
929
930
931
      [ 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)
932
      {- , ppr (seFloats env) -}
933
      ]) $ -}
934
    simplExprF1 env e cont
Ian Lynagh's avatar
Ian Lynagh committed
935

936
simplExprF1 :: SimplEnv -> InExpr -> SimplCont
Ian Lynagh's avatar
Ian Lynagh committed
937
            -> SimplM (SimplEnv, OutExpr)
938
939
simplExprF1 env (Var v)        cont = simplIdF env v cont
simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
940
simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont
941
942
943
944
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
945
946
947