Simplify.lhs 106 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}
Ian Lynagh's avatar
Ian Lynagh committed
7
8
9
10
11
12
13
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

14
module Simplify ( simplTopBinds, simplExpr ) where
15

16
#include "HsVersions.h"
17

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


55
56
The guts of the simplifier is in this module, but the driver loop for
the simplifier is in SimplCore.lhs.
57
58


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


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

Ian Lynagh's avatar
Ian Lynagh committed
86
87
88

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

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

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

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

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

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


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

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

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

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

On the other hand if we see the let-defns

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

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

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

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

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


208
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
209
%*                                                                      *
210
\subsection{Bindings}
Ian Lynagh's avatar
Ian Lynagh committed
211
%*                                                                      *
212
213
214
%************************************************************************

\begin{code}
215
simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
216

Ian Lynagh's avatar
Ian Lynagh committed
217
simplTopBinds env0 binds0
Ian Lynagh's avatar
Ian Lynagh committed
218
219
220
221
  = 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.
222
		-- See note [Glomming] in OccurAnal.
Ian Lynagh's avatar
Ian Lynagh committed
223
        ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
Ian Lynagh's avatar
Ian Lynagh committed
224
        ; dflags <- getDOptsSmpl
225
        ; let dump_flag = dopt Opt_D_verbose_core2core dflags
Ian Lynagh's avatar
Ian Lynagh committed
226
        ; env2 <- simpl_binds dump_flag env1 binds0
Ian Lynagh's avatar
Ian Lynagh committed
227
        ; freeTick SimplifierDone
228
        ; return env2 }
229
  where
Ian Lynagh's avatar
Ian Lynagh committed
230
231
232
233
234
235
        -- 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
236
    simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
237
238
    simpl_binds _    env []           = return env
    simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
Ian Lynagh's avatar
Ian Lynagh committed
239
240
                                                     simpl_bind env bind
                                           ; simpl_binds dump env' binds }
241

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

245
    simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
246
    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
Ian Lynagh's avatar
Ian Lynagh committed
247
248
        where
          (env', b') = addBndrRules env b (lookupRecBndr env b)
249
250
251
252
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
253
%*                                                                      *
254
\subsection{Lazy bindings}
Ian Lynagh's avatar
Ian Lynagh committed
255
%*                                                                      *
256
257
258
%************************************************************************

simplRecBind is used for
Ian Lynagh's avatar
Ian Lynagh committed
259
        * recursive bindings only
260
261
262

\begin{code}
simplRecBind :: SimplEnv -> TopLevelFlag
Ian Lynagh's avatar
Ian Lynagh committed
263
264
             -> [(InId, InExpr)]
             -> SimplM SimplEnv
Ian Lynagh's avatar
Ian Lynagh committed
265
266
267
268
269
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
270
        -- _and_ updates env0 with the in-scope set from env1
271
  where
272
    add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
Ian Lynagh's avatar
Ian Lynagh committed
273
        -- Add the (substituted) rules to the binder
274
    add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
Ian Lynagh's avatar
Ian Lynagh committed
275
276
        where
          (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
277

278
    go env [] = return env
Ian Lynagh's avatar
Ian Lynagh committed
279

280
    go env ((old_bndr, new_bndr, rhs) : pairs)
281
        = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
Ian Lynagh's avatar
Ian Lynagh committed
282
             ; go env' pairs }
283
284
\end{code}

285
simplOrTopPair is used for
Ian Lynagh's avatar
Ian Lynagh committed
286
287
        * recursive bindings (whether top level or not)
        * top-level non-recursive bindings
288
289
290
291
292

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

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

297
simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
Ian Lynagh's avatar
Ian Lynagh committed
298
299
300
  | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
  = do  { tick (PreInlineUnconditionally old_bndr)
        ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
301
302

  | otherwise
303
  = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
304
305
306
307
\end{code}


simplLazyBind is used for
308
309
  * [simplRecOrTopPair] recursive bindings (whether top level or not)
  * [simplRecOrTopPair] top-level non-recursive bindings
Ian Lynagh's avatar
Ian Lynagh committed
310
  * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
311
312

Nota bene:
Ian Lynagh's avatar
Ian Lynagh committed
313
    1. It assumes that the binder is *already* simplified,
314
       and is in scope, and its IdInfo too, except unfolding
315
316
317
318
319
320
321
322

    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
323
324
325
326
327
              -> 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
328

329
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
330
331
  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
    do  { let   rhs_env     = rhs_se `setInScope` env
332
333
334
335
336
337
338
339
340
341
		(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

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

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

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

        ; completeBind env' top_lvl bndr bndr1 rhs' }
368
\end{code}
369

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

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

simplNonRecX env bndr new_rhs
380
381
382
383
  | 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    
384
  = return (extendCvSubst env bndr co)
385
  | otherwise		--		 the binding b = (a,b)
Ian Lynagh's avatar
Ian Lynagh committed
386
  = do  { (env', bndr') <- simplBinder env bndr
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
387
388
        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
		-- simplNonRecX is only used for NotTopLevel things
389

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
397
398
completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
  = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
399
        ; (env2, rhs2) <- 
400
                if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
Ian Lynagh's avatar
Ian Lynagh committed
401
402
403
404
                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 }
405
406
407
408
\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
409
   In the cases described by the folowing commment, postInlineUnconditionally will
410
   catch many of the relevant cases.
Ian Lynagh's avatar
Ian Lynagh committed
411
412
413
414
415
416
417
418
        -- 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.
419

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

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

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

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

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

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

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

489

490
491
492
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
Ian Lynagh's avatar
Ian Lynagh committed
493
        x = e `cast` co
494
we'd like to transform it to
Ian Lynagh's avatar
Ian Lynagh committed
495
496
        x' = e
        x = x `cast` co         -- A trivial binding
497
498
499
500
501
502
503
504
505
506
507
508
509
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
510
                -- This case should optimise
511

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

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

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

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

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

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

539
540

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

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

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
Note [Cannot trivialise]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider tih
   f :: Int -> Addr#
   
   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.
603

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

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

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

627
628
Nor does it do the atomic-argument thing

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

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

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

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

655
      	-- Simplify the unfolding
656
      ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
657

658
659
660
      ; if postInlineUnconditionally env top_lvl new_bndr occ_info
                                     final_rhs new_unfolding

661
	                -- Inline and discard the binding
662
	then do  { tick (PostInlineUnconditionally old_bndr)
663
	         ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
664
665
	        -- Use the substitution to make quite, quite sure that the
	        -- substitution will happen, since we are going to discard the binding
666
667
668
669
670
671
672
	else
   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
	
              -- Unfolding info: Note [Setting the new unfolding]
	    info2 = info1 `setUnfoldingInfo` new_unfolding

	      -- Demand info: Note [Setting the demand info]
673
674
675
676
677
678
679
680
681
682
683
              --
              -- 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
684
685

            final_id = new_bndr `setIdInfo` info3
686

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

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

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

713
        ; return (addNonRec env final_id rhs) }
714

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

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

732
simplUnfolding env top_lvl id _
733
    (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
734
                   , uf_src = src, uf_guidance = guide })
735
  | isStableSource src
736
737
  = do { expr' <- simplExpr rule_env expr
       ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
738
739
             is_top_lvl = isTopLevel top_lvl
       ; case guide of
740
741
742
743
744
745
746
747
748
749
750
751
752
753
           UnfWhen sat_ok _    -- Happens for INLINE things
              -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
	      	     -- 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
                 in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
		 -- See Note [Top-level flag on inline rules] in CoreUnfold

           _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')
754
755
756
757
                -- 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.
       }
758
  where
759
760
    act      = idInlineActivation id
    rule_env = updMode (updModeForInlineRules act) env
761
       	       -- See Note [Simplifying inside InlineRules] in SimplUtils
762

763
764
765
766
767
768
769
770
771
772
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)
	  -- 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.
773
\end{code}
774

775
776
777
778
779
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).

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

	$s$dm {Arity 0} = \x. op dInt }

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

803
804
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
833
834
Note [Setting the new unfolding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
  should do nothing at all, but simplifying gently might get rid of 
  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...

835

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

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

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

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


880
\begin{code}
881
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
882
simplExpr env expr = simplExprC env expr mkBoringStop
883

884
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
Ian Lynagh's avatar
Ian Lynagh committed
885
886
        -- Simplify an expression, given a continuation
simplExprC env expr cont
887
  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
Ian Lynagh's avatar
Ian Lynagh committed
888
889
890
891
    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')) $
892
893
894
895
          return (wrapFloats env' expr') }

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

Ian Lynagh's avatar
Ian Lynagh committed
898
simplExprF env e cont
899
900
901
902
903
904
905
906
907
  = {- pprTrace "simplExprF" (vcat 
      [ 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)
      {- , ppr (seFloats env) -} 
      ]) $ -}
908
    simplExprF1 env e cont
Ian Lynagh's avatar
Ian Lynagh committed
909

910
simplExprF1 :: SimplEnv -> InExpr -> SimplCont
Ian Lynagh's avatar
Ian Lynagh committed
911
            -> SimplM (SimplEnv, OutExpr)
912
913
simplExprF1 env (Var v)        cont = simplIdF env v cont
simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
914
simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont
915
916
917
918
919
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
920
                                      ApplyTo NoDup arg env cont
921

922
simplExprF1 env expr@(Lam {}) cont
923
  = simplLam env zapped_bndrs body cont
Ian Lynagh's avatar
Ian Lynagh committed
924
925
926
927
928
        -- 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
929
        -- occ-info, UNLESS the remaining binders are one-shot
930
931
  where
    (bndrs, body) = collectBinders expr
932
933
934
935
936
937
938
    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)
939

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
961
962
        ; env'' <- simplRecBind env' NotTopLevel pairs
        ; simplExprF env'' body cont }
963

964
simplExprF1 env (Let (NonRec bndr rhs) body) cont
965
  = simplNonRecE env bndr (rhs, env) ([], body) cont
966
967

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

---------------------------------
977
978
979
980
981
982
983
984
985
simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
               -> SimplM (SimplEnv, OutExpr)
-- We are simplifying a term of form (Coercion co)
-- Simplify the InCoercion, and then try to combine with the 
-- context, to implememt the rule
--     (Coercion co) |> g
--  =  Coercion (syn (nth 0 g) ; co ; nth 1 g) 
simplCoercionF env co cont 
  = do { co' <- simplCoercion env co
986
       ; rebuild env (Coercion co') cont }
987

988
simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
989
simplCoercion env co
990
  = let opt_co = optCoercion (getCvSubst env) co
991
    in seqCo opt_co `seq` return opt_co
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029

-----------------------------------
-- | Push a TickIt context outwards past applications and cases, as
-- long as this is a non-scoping tick, to let case and application
-- optimisations apply.

simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
          -> SimplM (SimplEnv, OutExpr)
simplTick env tickish expr cont
  -- A scoped tick turns into a continuation, so that we can spot
  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do
  -- it this way, then it would take two passes of the simplifier to
  -- reduce ((scc t (\x . e)) e').
  -- NB, don't do this with counting ticks, because if the expr is
  -- bottom, then rebuildCall will discard the continuation.

-- XXX: we cannot do this, because the simplifier assumes that
-- the context can be pushed into a case with a single branch. e.g.
--    scc<f>  case expensive of p -> e
-- becomes
--    case expensive of p -> scc<f> e
--
-- So I'm disabling this for now.  It just means we will do more
-- simplifier iterations that necessary in some cases.

--  | tickishScoped tickish && not (tickishCounts tickish)
--  = simplExprF env expr (TickIt tickish cont)

  -- For non-scoped ticks, we push the continuation inside the
  -- tick.  This has the effect of moving the tick to the outside of a
  -- case or application context, allowing the normal case and
  -- application optimisations to fire.
  | not (tickishScoped tickish)
  = do { (env', expr') <- simplExprF env expr cont
       ; return (env', mkTick tickish expr')
       }

  -- For breakpoints, we cannot do any floating of bindings around the
1030
  -- tick, because breakpoints cannot be split into tick/scope pairs.
1031
1032
  | not (tickishCanSplit tickish)
  = no_floating_past_tick
1033

1034
  | interesting_cont, Just expr' <- push_tick_inside tickish expr
Simon Marlow's avatar
Simon Marlow committed
1035
1036
1037
    -- see Note [case-of-scc-of-case]
  = simplExprF env expr' cont

1038
  | otherwise
1039
1040
  = no_floating_past_tick -- was: wrap_floats, see below

1041
 where
1042
1043
1044
1045
1046
1047
  interesting_cont = case cont of
                        Select _ _ _ _ _ -> True
                        _ -> False

  push_tick_inside t expr0
     | not (tickishCanSplit t) = Nothing
Simon Marlow's avatar
Simon Marlow committed
1048
     | otherwise
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
       = case expr0 of
           Tick t' expr
              -- scc t (tick t' E)
              --   Pull the tick to the outside
              -- This one is important for #5363
              | not (tickishScoped t')
                 -> Just (Tick t' (Tick t expr))

              -- scc t (scc t' E)
              --   Try to push t' into E first, and if that works,
              --   try to push t in again
              | Just expr' <- push_tick_inside t' expr
                 -> push_tick_inside t expr'

              | otherwise -> Nothing

Simon Marlow's avatar
Simon Marlow committed
1065
           Case scrut bndr ty alts
1066
1067
              -> Just (Case (mkTick t scrut) bndr ty alts')
             where t_scope = mkNoTick t -- drop the tick on the dup'd ones
Simon Marlow's avatar
Simon Marlow committed
1068
1069
                   alts'   = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
           _other -> Nothing
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
    where

  no_floating_past_tick =
    do { let (inc,outc) = splitCont cont
       ; (env', expr') <- simplExprF (zapFloats env) expr inc
       ; let tickish' = simplTickish env tickish
       ; (env'', expr'') <- rebuild (zapFloats env')
                                    (wrapFloats env' expr')
                                    (TickIt tickish' outc)
       ; return (addFloats env env'', expr'')
       }
Simon Marlow's avatar
Simon Marlow committed
1081

1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
-- Alternative version that wraps outgoing floats with the tick.  This
-- results in ticks being duplicated, as we don't make any attempt to
-- eliminate the tick if we re-inline the binding (because the tick
-- semantics allows unrestricted inlining of HNFs), so I'm not doing
-- this any more.  FloatOut will catch any real opportunities for
-- floating.
--
--  wrap_floats =
--    do { let (inc,outc) = splitCont cont
--       ; (env', expr') <- simplExprF (zapFloats env) expr inc
--       ; let tickish' = simplTickish env tickish
--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
--                                   mkTick (mkNoTick tickish') rhs)
--              -- when wrapping a float with mkTick, we better zap the Id's
--              -- strictness info and arity, because it might be wrong now.
--       ; let env'' = addFloats env (mapFloats env' wrap_float)
--       ; rebuild env'' expr' (TickIt tickish' outc)
--       }
Simon Marlow's avatar
Simon Marlow committed
1100
1101


1102
1103
1104
1105
1106
  simplTickish env tickish
    | Breakpoint n ids <- tickish
          = Breakpoint n (map (getDoneId . substId env) ids)
    | otherwise = tickish

1107
1108
1109
1110
1111
1112
1113
1114
  -- push type application and coercion inside a tick
  splitCont :: SimplCont -> (SimplCont, SimplCont)
  splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc)
    where (inc,outc) = splitCont c
  splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
    where (inc,outc) = splitCont c
  splitCont other = (mkBoringStop, other)

1115
1116
1117
  getDoneId (DoneId id) = id
  getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
  getDoneId other = pprPanic "getDoneId" (ppr other)
Simon Marlow's avatar
Simon Marlow committed
1118
1119
1120
1121