Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / compiler / simplCore / Simplify.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[Simplify]{The main module of the simplifier}
5
6 \begin{code}
7 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module Simplify ( simplTopBinds, simplExpr ) where
15
16 #include "HsVersions.h"
17
18 import DynFlags
19 import SimplMonad
20 import Type hiding      ( substTy, extendTvSubst, substTyVar )
21 import SimplEnv
22 import SimplUtils
23 import FamInstEnv       ( FamInstEnv )
24 import Literal          ( litIsLifted )
25 import Id
26 import MkId             ( seqId, realWorldPrimId )
27 import MkCore           ( mkImpossibleExpr )
28 import IdInfo
29 import Name             ( mkSystemVarName, isExternalName )
30 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
31 import OptCoercion      ( optCoercion )
32 import FamInstEnv       ( topNormaliseType )
33 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
34 import CoreMonad        ( Tick(..), SimplifierMode(..) )
35 import CoreSyn
36 import Demand           ( isStrictDmd, StrictSig(..), dmdTypeDepth )
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 )
44 import TysPrim          ( realWorldStatePrimTy )
45 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
46 import MonadUtils       ( foldlM, mapAccumLM )
47 import Maybes           ( orElse, isNothing )
48 import Data.List        ( mapAccumL )
49 import Outputable
50 import FastString
51 import Pair
52 \end{code}
53
54
55 The guts of the simplifier is in this module, but the driver loop for
56 the simplifier is in SimplCore.lhs.
57
58
59 -----------------------------------------
60         *** IMPORTANT NOTE ***
61 -----------------------------------------
62 The simplifier used to guarantee that the output had no shadowing, but
63 it does not do so any more.   (Actually, it never did!)  The reason is
64 documented with simplifyArgs.
65
66
67 -----------------------------------------
68         *** IMPORTANT NOTE ***
69 -----------------------------------------
70 Many parts of the simplifier return a bunch of "floats" as well as an
71 expression. This is wrapped as a datatype SimplUtils.FloatsWith.
72
73 All "floats" are let-binds, not case-binds, but some non-rec lets may
74 be unlifted (with RHS ok-for-speculation).
75
76
77
78 -----------------------------------------
79         ORGANISATION OF FUNCTIONS
80 -----------------------------------------
81 simplTopBinds
82   - simplify all top-level binders
83   - for NonRec, call simplRecOrTopPair
84   - for Rec,    call simplRecBind
85
86
87         ------------------------------
88 simplExpr (applied lambda)      ==> simplNonRecBind
89 simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
90 simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind
91
92         ------------------------------
93 simplRecBind    [binders already simplfied]
94   - use simplRecOrTopPair on each pair in turn
95
96 simplRecOrTopPair [binder already simplified]
97   Used for: recursive bindings (top level and nested)
98             top-level non-recursive bindings
99   Returns:
100   - check for PreInlineUnconditionally
101   - simplLazyBind
102
103 simplNonRecBind
104   Used for: non-top-level non-recursive bindings
105             beta reductions (which amount to the same thing)
106   Because it can deal with strict arts, it takes a
107         "thing-inside" and returns an expression
108
109   - check for PreInlineUnconditionally
110   - simplify binder, including its IdInfo
111   - if strict binding
112         simplStrictArg
113         mkAtomicArgs
114         completeNonRecX
115     else
116         simplLazyBind
117         addFloats
118
119 simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
120   Used for: binding case-binder and constr args in a known-constructor case
121   - check for PreInLineUnconditionally
122   - simplify binder
123   - completeNonRecX
124
125         ------------------------------
126 simplLazyBind:  [binder already simplified, RHS not]
127   Used for: recursive bindings (top level and nested)
128             top-level non-recursive bindings
129             non-top-level, but *lazy* non-recursive bindings
130         [must not be strict or unboxed]
131   Returns floats + an augmented environment, not an expression
132   - substituteIdInfo and add result to in-scope
133         [so that rules are available in rec rhs]
134   - simplify rhs
135   - mkAtomicArgs
136   - float if exposes constructor or PAP
137   - completeBind
138
139
140 completeNonRecX:        [binder and rhs both simplified]
141   - if the the thing needs case binding (unlifted and not ok-for-spec)
142         build a Case
143    else
144         completeBind
145         addFloats
146
147 completeBind:   [given a simplified RHS]
148         [used for both rec and non-rec bindings, top level and not]
149   - try PostInlineUnconditionally
150   - add unfolding [this is the only place we add an unfolding]
151   - add arity
152
153
154
155 Right hand sides and arguments
156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
157 In many ways we want to treat
158         (a) the right hand side of a let(rec), and
159         (b) a function argument
160 in the same way.  But not always!  In particular, we would
161 like to leave these arguments exactly as they are, so they
162 will match a RULE more easily.
163
164         f (g x, h x)
165         g (+ x)
166
167 It's harder to make the rule match if we ANF-ise the constructor,
168 or eta-expand the PAP:
169
170         f (let { a = g x; b = h x } in (a,b))
171         g (\y. + x y)
172
173 On the other hand if we see the let-defns
174
175         p = (g x, h x)
176         q = + x
177
178 then we *do* want to ANF-ise and eta-expand, so that p and q
179 can be safely inlined.
180
181 Even floating lets out is a bit dubious.  For let RHS's we float lets
182 out if that exposes a value, so that the value can be inlined more vigorously.
183 For example
184
185         r = let x = e in (x,x)
186
187 Here, if we float the let out we'll expose a nice constructor. We did experiments
188 that showed this to be a generally good thing.  But it was a bad thing to float
189 lets out unconditionally, because that meant they got allocated more often.
190
191 For function arguments, there's less reason to expose a constructor (it won't
192 get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
193 So for the moment we don't float lets out of function arguments either.
194
195
196 Eta expansion
197 ~~~~~~~~~~~~~~
198 For eta expansion, we want to catch things like
199
200         case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
201
202 If the \x was on the RHS of a let, we'd eta expand to bring the two
203 lambdas together.  And in general that's a good thing to do.  Perhaps
204 we should eta expand wherever we find a (value) lambda?  Then the eta
205 expansion at a let RHS can concentrate solely on the PAP case.
206
207
208 %************************************************************************
209 %*                                                                      *
210 \subsection{Bindings}
211 %*                                                                      *
212 %************************************************************************
213
214 \begin{code}
215 simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
216
217 simplTopBinds env0 binds0
218   = do  {       -- Put all the top-level binders into scope at the start
219                 -- so that if a transformation rule has unexpectedly brought
220                 -- anything into scope, then we don't get a complaint about that.
221                 -- It's rather as if the top-level binders were imported.
222                 -- See note [Glomming] in OccurAnal.
223         ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
224         ; dflags <- getDOptsSmpl
225         ; let dump_flag = dopt Opt_D_verbose_core2core dflags
226         ; env2 <- simpl_binds dump_flag env1 binds0
227         ; freeTick SimplifierDone
228         ; return env2 }
229   where
230         -- We need to track the zapped top-level binders, because
231         -- they should have their fragile IdInfo zapped (notably occurrence info)
232         -- That's why we run down binds and bndrs' simultaneously.
233         --
234         -- The dump-flag emits a trace for each top-level binding, which
235         -- helps to locate the tracing for inlining and rule firing
236     simpl_binds :: Bool -> SimplEnv -> [InBind] -> SimplM SimplEnv
237     simpl_binds _    env []           = return env
238     simpl_binds dump env (bind:binds) = do { env' <- trace_bind dump bind $
239                                                      simpl_bind env bind
240                                            ; simpl_binds dump env' binds }
241
242     trace_bind True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
243     trace_bind False _    = \x -> x
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
247         where
248           (env', b') = addBndrRules env b (lookupRecBndr env b)
249 \end{code}
250
251
252 %************************************************************************
253 %*                                                                      *
254 \subsection{Lazy bindings}
255 %*                                                                      *
256 %************************************************************************
257
258 simplRecBind is used for
259         * recursive bindings only
260
261 \begin{code}
262 simplRecBind :: SimplEnv -> TopLevelFlag
263              -> [(InId, InExpr)]
264              -> SimplM SimplEnv
265 simplRecBind env0 top_lvl pairs0
266   = do  { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
267         ; env1 <- go (zapFloats env_with_info) triples
268         ; return (env0 `addRecFloats` env1) }
269         -- addFloats adds the floats from env1,
270         -- _and_ updates env0 with the in-scope set from env1
271   where
272     add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
273         -- Add the (substituted) rules to the binder
274     add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
275         where
276           (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
277
278     go env [] = return env
279
280     go env ((old_bndr, new_bndr, rhs) : pairs)
281         = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
282              ; go env' pairs }
283 \end{code}
284
285 simplOrTopPair is used for
286         * recursive bindings (whether top level or not)
287         * top-level non-recursive bindings
288
289 It assumes the binder has already been simplified, but not its IdInfo.
290
291 \begin{code}
292 simplRecOrTopPair :: SimplEnv
293                   -> TopLevelFlag -> RecFlag
294                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
295                   -> SimplM SimplEnv    -- Returns an env that includes the binding
296
297 simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
298   | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
299   = do  { tick (PreInlineUnconditionally old_bndr)
300         ; 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 \end{code}
305
306
307 simplLazyBind is used for
308   * [simplRecOrTopPair] recursive bindings (whether top level or not)
309   * [simplRecOrTopPair] top-level non-recursive bindings
310   * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
311
312 Nota bene:
313     1. It assumes that the binder is *already* simplified,
314        and is in scope, and its IdInfo too, except unfolding
315
316     2. It assumes that the binder type is lifted.
317
318     3. It does not check for pre-inline-unconditionallly;
319        that should have been done already.
320
321 \begin{code}
322 simplLazyBind :: SimplEnv
323               -> TopLevelFlag -> RecFlag
324               -> InId -> OutId          -- Binder, both pre-and post simpl
325                                         -- The OutId has IdInfo, except arity, unfolding
326               -> InExpr -> SimplEnv     -- The RHS and its environment
327               -> SimplM SimplEnv
328
329 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
330   = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
331     do  { let   rhs_env     = rhs_se `setInScope` env
332                 (tvs, body) = case collectTyBinders rhs of
333                                 (tvs, body) | not_lam body -> (tvs,body)
334                                             | otherwise    -> ([], rhs)
335                 not_lam (Lam _ _) = False
336                 not_lam _         = True
337                         -- Do not do the "abstract tyyvar" thing if there's
338                         -- a lambda inside, becuase it defeats eta-reduction
339                         --    f = /\a. \x. g a x  
340                         -- should eta-reduce
341
342         ; (body_env, tvs') <- simplBinders rhs_env tvs
343                 -- See Note [Floating and type abstraction] in SimplUtils
344
345         -- Simplify the RHS
346         ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
347         -- ANF-ise a constructor or PAP rhs
348         ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
349
350         ; (env', rhs')
351             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
352                 then                            -- No floating, revert to body1
353                      do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1)
354                         ; return (env, rhs') }
355
356                 else if null tvs then           -- Simple floating
357                      do { tick LetFloatFromLet
358                         ; return (addFloats env body_env2, body2) }
359
360                 else                            -- Do type-abstraction first
361                      do { tick LetFloatFromLet
362                         ; (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') }
366
367         ; completeBind env' top_lvl bndr bndr1 rhs' }
368 \end{code}
369
370 A specialised variant of simplNonRec used when the RHS is already simplified,
371 notably in knownCon.  It uses case-binding where necessary.
372
373 \begin{code}
374 simplNonRecX :: SimplEnv
375              -> InId            -- Old binder
376              -> OutExpr         -- Simplified RHS
377              -> SimplM SimplEnv
378
379 simplNonRecX env bndr new_rhs
380   | isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
381   = return env          --               Here c is dead, and we avoid creating
382                         --               the binding c = (a,b)
383   | Coercion co <- new_rhs    
384   = return (extendCvSubst env bndr co)
385   | otherwise           --               the binding b = (a,b)
386   = do  { (env', bndr') <- simplBinder env bndr
387         ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
388                 -- simplNonRecX is only used for NotTopLevel things
389
390 completeNonRecX :: TopLevelFlag -> SimplEnv
391                 -> Bool
392                 -> InId                 -- Old binder
393                 -> OutId                -- New binder
394                 -> OutExpr              -- Simplified RHS
395                 -> SimplM SimplEnv
396
397 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
398   = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
399         ; (env2, rhs2) <- 
400                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
401                 then do { tick LetFloatFromLet
402                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
403                 else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
404         ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
405 \end{code}
406
407 {- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
408    Doing so risks exponential behaviour, because new_rhs has been simplified once already
409    In the cases described by the folowing commment, postInlineUnconditionally will
410    catch many of the relevant cases.
411         -- This happens; for example, the case_bndr during case of
412         -- known constructor:  case (a,b) of x { (p,q) -> ... }
413         -- Here x isn't mentioned in the RHS, so we don't want to
414         -- create the (dead) let-binding  let x = (a,b) in ...
415         --
416         -- Similarly, single occurrences can be inlined vigourously
417         -- e.g.  case (f x, g y) of (a,b) -> ....
418         -- 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
421         -- Consider     case I# (quotInt# x y) of
422         --                I# v -> let w = J# v in ...
423         -- If we gaily inline (quotInt# x y) for v, we end up building an
424         -- extra thunk:
425         --                let w = J# (quotInt# x y) in ...
426         -- because quotInt# can fail.
427
428   | preInlineUnconditionally env NotTopLevel bndr new_rhs
429   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
430 -}
431
432 ----------------------------------
433 prepareRhs takes a putative RHS, checks whether it's a PAP or
434 constructor application and, if so, converts it to ANF, so that the
435 resulting thing can be inlined more easily.  Thus
436         x = (f a, g b)
437 becomes
438         t1 = f a
439         t2 = g b
440         x = (t1,t2)
441
442 We also want to deal well cases like this
443         v = (f e1 `cast` co) e2
444 Here we want to make e1,e2 trivial and get
445         x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
446 That's what the 'go' loop in prepareRhs does
447
448 \begin{code}
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
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
453   , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
454   = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
455         ; return (env', Cast rhs' co) }
456   where
457     sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
458                                    `setDemandInfo`     demandInfo info
459     info = idInfo id
460
461 prepareRhs top_lvl env0 _ rhs0
462   = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
463         ; return (env1, rhs1) }
464   where
465     go n_val_args env (Cast rhs co)
466         = do { (is_exp, env', rhs') <- go n_val_args env rhs
467              ; return (is_exp, env', Cast rhs' co) }
468     go n_val_args env (App fun (Type ty))
469         = do { (is_exp, env', rhs') <- go n_val_args env fun
470              ; return (is_exp, env', App rhs' (Type ty)) }
471     go n_val_args env (App fun arg)
472         = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
473              ; case is_exp of
474                 True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
475                            ; return (True, env'', App fun' arg') }
476                 False -> return (False, env, App fun arg) }
477     go n_val_args env (Var fun)
478         = return (is_exp, env, Var fun)
479         where
480           is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
481                         -- See Note [CONLIKE pragma] in BasicTypes
482                         -- The definition of is_exp should match that in
483                         -- OccurAnal.occAnalApp
484
485     go _ env other
486         = return (False, env, other)
487 \end{code}
488
489
490 Note [Float coercions]
491 ~~~~~~~~~~~~~~~~~~~~~~
492 When we find the binding
493         x = e `cast` co
494 we'd like to transform it to
495         x' = e
496         x = x `cast` co         -- A trivial binding
497 There's a chance that e will be a constructor application or function, or something
498 like that, so moving the coerion to the usage site may well cancel the coersions
499 and lead to further optimisation.  Example:
500
501      data family T a :: *
502      data instance T Int = T Int
503
504      foo :: Int -> Int -> Int
505      foo m n = ...
506         where
507           x = T m
508           go 0 = 0
509           go n = case x of { T m -> go (n-m) }
510                 -- This case should optimise
511
512 Note [Preserve strictness when floating coercions]
513 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
514 In the Note [Float coercions] transformation, keep the strictness info.
515 Eg
516         f = e `cast` co    -- f has strictness SSL
517 When we transform to
518         f' = e             -- f' also has strictness SSL
519         f = f' `cast` co   -- f still has strictness SSL
520
521 Its not wrong to drop it on the floor, but better to keep it.
522
523 Note [Float coercions (unlifted)]
524 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
525 BUT don't do [Float coercions] if 'e' has an unlifted type.
526 This *can* happen:
527
528      foo :: Int = (error (# Int,Int #) "urk")
529                   `cast` CoUnsafe (# Int,Int #) Int
530
531 If do the makeTrivial thing to the error call, we'll get
532     foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
533 But 'v' isn't in scope!
534
535 These strange casts can happen as a result of case-of-case
536         bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
537                 (# p,q #) -> p+q
538
539
540 \begin{code}
541 makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
542 -- Binds the expression to a variable, if it's not trivial, returning the variable
543 makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
544
545 makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo 
546                     -> OutExpr -> SimplM (SimplEnv, OutExpr)
547 -- Propagate strictness and demand info to the new binder
548 -- Note [Preserve strictness when floating coercions]
549 -- Returned SimplEnv has same substitution as incoming one
550 makeTrivialWithInfo top_lvl env info expr
551   | exprIsTrivial expr                          -- Already trivial
552   || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
553                                                 --   See Note [Cannot trivialise]
554   = return (env, expr)
555   | otherwise           -- See Note [Take care] below
556   = do  { uniq <- getUniqueM
557         ; let name = mkSystemVarName uniq (fsLit "a")
558               var = mkLocalIdWithInfo name expr_ty info
559         ; env'  <- completeNonRecX top_lvl env False var var expr
560         ; expr' <- simplVar env' var
561         ; return (env', expr') }
562         -- The simplVar is needed becase we're constructing a new binding
563         --     a = rhs
564         -- And if rhs is of form (rhs1 |> co), then we might get
565         --     a1 = rhs1
566         --     a = a1 |> co
567         -- and now a's RHS is trivial and can be substituted out, and that
568         -- is what completeNonRecX will do
569         -- To put it another way, it's as if we'd simplified
570         --    let var = e in var
571   where
572     expr_ty = exprType expr
573
574 bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
575 -- True iff we can have a binding of this expression at this level
576 -- Precondition: the type is the type of the expression
577 bindingOk top_lvl _ expr_ty
578   | isTopLevel top_lvl = not (isUnLiftedType expr_ty) 
579   | otherwise          = True
580 \end{code}
581
582 Note [Cannot trivialise]
583 ~~~~~~~~~~~~~~~~~~~~~~~~
584 Consider tih
585    f :: Int -> Addr#
586    
587    foo :: Bar
588    foo = Bar (f 3)
589
590 Then we can't ANF-ise foo, even though we'd like to, because
591 we can't make a top-level binding for the Addr# (f 3). And if
592 so we don't want to turn it into
593    foo = let x = f 3 in Bar x
594 because we'll just end up inlining x back, and that makes the
595 simplifier loop.  Better not to ANF-ise it at all.
596
597 A case in point is literal strings (a MachStr is not regarded as
598 trivial):
599
600    foo = Ptr "blob"#
601
602 We don't want to ANF-ise this.
603
604 %************************************************************************
605 %*                                                                      *
606 \subsection{Completing a lazy binding}
607 %*                                                                      *
608 %************************************************************************
609
610 completeBind
611   * deals only with Ids, not TyVars
612   * takes an already-simplified binder and RHS
613   * is used for both recursive and non-recursive bindings
614   * is used for both top-level and non-top-level bindings
615
616 It does the following:
617   - tries discarding a dead binding
618   - tries PostInlineUnconditionally
619   - add unfolding [this is the only place we add an unfolding]
620   - add arity
621
622 It does *not* attempt to do let-to-case.  Why?  Because it is used for
623   - top-level bindings (when let-to-case is impossible)
624   - many situations where the "rhs" is known to be a WHNF
625                 (so let-to-case is inappropriate).
626
627 Nor does it do the atomic-argument thing
628
629 \begin{code}
630 completeBind :: SimplEnv
631              -> TopLevelFlag            -- Flag stuck into unfolding
632              -> InId                    -- Old binder
633              -> OutId -> OutExpr        -- New binder and RHS
634              -> SimplM SimplEnv
635 -- completeBind may choose to do its work
636 --      * by extending the substitution (e.g. let x = y in ...)
637 --      * or by adding to the floats in the envt
638
639 completeBind env top_lvl old_bndr new_bndr new_rhs
640  | isCoVar old_bndr
641  = case new_rhs of
642      Coercion co -> return (extendCvSubst env old_bndr co)
643      _           -> return (addNonRec env new_bndr new_rhs)
644
645  | otherwise
646  = ASSERT( isId new_bndr )
647    do { let old_info = idInfo old_bndr
648             old_unf  = unfoldingInfo old_info
649             occ_info = occInfo old_info
650
651         -- Do eta-expansion on the RHS of the binding
652         -- See Note [Eta-expanding at let bindings] in SimplUtils
653       ; (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       ; if postInlineUnconditionally env top_lvl new_bndr occ_info
659                                      final_rhs new_unfolding
660
661                         -- Inline and discard the binding
662         then do  { tick (PostInlineUnconditionally old_bndr)
663                  ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
664                 -- Use the substitution to make quite, quite sure that the
665                 -- substitution will happen, since we are going to discard the binding
666         else
667    do { let info1 = idInfo new_bndr `setArityInfo` new_arity
668         
669               -- Unfolding info: Note [Setting the new unfolding]
670             info2 = info1 `setUnfoldingInfo` new_unfolding
671
672               -- Demand info: Note [Setting the demand info]
673               --
674               -- We also have to nuke demand info if for some reason
675               -- eta-expansion *reduces* the arity of the binding to less
676               -- than that of the strictness sig. This can happen: see Note [Arity decrease].
677             info3 | isEvaldUnfolding new_unfolding
678                     || (case strictnessInfo info2 of
679                           Just (StrictSig dmd_ty) -> new_arity < dmdTypeDepth dmd_ty
680                           Nothing                 -> False)
681                   = zapDemandInfo info2 `orElse` info2
682                   | otherwise
683                   = info2
684
685             final_id = new_bndr `setIdInfo` info3
686
687       ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
688         return (addNonRec env final_id final_rhs) } }
689                 -- The addNonRec adds it to the in-scope set too
690
691 ------------------------------
692 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
693 -- Add a new binding to the environment, complete with its unfolding
694 -- but *do not* do postInlineUnconditionally, because we have already
695 -- processed some of the scope of the binding
696 -- We still want the unfolding though.  Consider
697 --      let 
698 --            x = /\a. let y = ... in Just y
699 --      in body
700 -- Then we float the y-binding out (via abstractFloats and addPolyBind)
701 -- but 'x' may well then be inlined in 'body' in which case we'd like the 
702 -- 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                         -- Assumes that poly_id did not have an INLINE prag
709                         -- which is perhaps wrong.  ToDo: think about this
710         ; let final_id = setIdInfo poly_id $
711                          idInfo poly_id `setUnfoldingInfo` unfolding
712
713         ; return (addNonRec env final_id rhs) }
714
715 addPolyBind _ env bind@(Rec _) 
716   = return (extendFloats env bind)
717         -- Hack: letrecs are more awkward, so we extend "by steam"
718         -- without adding unfoldings etc.  At worst this leads to
719         -- more simplifier iterations
720
721 ------------------------------
722 simplUnfolding :: SimplEnv-> TopLevelFlag
723                -> InId
724                -> OutExpr
725                -> Unfolding -> SimplM Unfolding
726 -- 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   = do { expr' <- simplExpr rule_env expr
737        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
738              is_top_lvl = isTopLevel top_lvl
739        ; case guide of
740            UnfWhen sat_ok _    -- Happens for INLINE things
741               -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
742                      -- Refresh the boring-ok flag, in case expr'
743                      -- has got small. This happens, notably in the inlinings
744                      -- for dfuns for single-method classes; see
745                      -- Note [Single-method classes] in TcInstDcls.
746                      -- A test case is Trac #4138
747                  in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
748                  -- See Note [Top-level flag on inline rules] in CoreUnfold
749
750            _other              -- Happens for INLINABLE things
751               -> let bottoming = isBottomingId id
752                  in bottoming `seq` -- See Note [Force bottoming field]
753                     return (mkUnfolding src' is_top_lvl bottoming expr')
754                 -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
755                 -- unfolding, and we need to make sure the guidance is kept up
756                 -- to date with respect to any changes in the unfolding.
757        }
758   where
759     act      = idInlineActivation id
760     rule_env = updMode (updModeForInlineRules act) env
761                -- See Note [Simplifying inside InlineRules] in SimplUtils
762
763 simplUnfolding _ top_lvl id new_rhs _
764   = let bottoming = isBottomingId id
765     in bottoming `seq`  -- See Note [Force bottoming field]
766        return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
767           -- We make an  unfolding *even for loop-breakers*.
768           -- Reason: (a) It might be useful to know that they are WHNF
769           --         (b) In TidyPgm we currently assume that, if we want to
770           --             expose the unfolding then indeed we *have* an unfolding
771           --             to expose.  (We could instead use the RHS, but currently
772           --             we don't.)  The simple thing is always to have one.
773 \end{code}
774
775 Note [Force bottoming field]
776 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
777 We need to force bottoming, or the new unfolding holds
778 on to the old unfolding (which is part of the id).
779
780 Note [Arity decrease]
781 ~~~~~~~~~~~~~~~~~~~~~
782 Generally speaking the arity of a binding should not decrease.  But it *can* 
783 legitimately happen becuase of RULES.  Eg
784         f = g Int
785 where g has arity 2, will have arity 2.  But if there's a rewrite rule
786         g Int --> h
787 where h has arity 1, then f's arity will decrease.  Here's a real-life example,
788 which is in the output of Specialise:
789
790      Rec {
791         $dm {Arity 2} = \d.\x. op d
792         {-# RULES forall d. $dm Int d = $s$dm #-}
793         
794         dInt = MkD .... opInt ...
795         opInt {Arity 1} = $dm dInt
796
797         $s$dm {Arity 0} = \x. op dInt }
798
799 Here opInt has arity 1; but when we apply the rule its arity drops to 0.
800 That's why Specialise goes to a little trouble to pin the right arity
801 on specialised functions too.
802
803 Note [Setting the new unfolding]
804 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
805 * If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
806   should do nothing at all, but simplifying gently might get rid of 
807   more crap.
808
809 * If not, we make an unfolding from the new RHS.  But *only* for
810   non-loop-breakers. Making loop breakers not have an unfolding at all
811   means that we can avoid tests in exprIsConApp, for example.  This is
812   important: if exprIsConApp says 'yes' for a recursive thing, then we
813   can get into an infinite loop
814
815 If there's an InlineRule on a loop breaker, we hang on to the inlining.
816 It's pretty dodgy, but the user did say 'INLINE'.  May need to revisit
817 this choice.
818
819 Note [Setting the demand info]
820 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
821 If the unfolding is a value, the demand info may
822 go pear-shaped, so we nuke it.  Example:
823      let x = (a,b) in
824      case x of (p,q) -> h p q x
825 Here x is certainly demanded. But after we've nuked
826 the case, we'll get just
827      let x = (a,b) in h a b x
828 and now x is not demanded (I'm assuming h is lazy)
829 This really happens.  Similarly
830      let f = \x -> e in ...f..f...
831 After inlining f at some of its call sites the original binding may
832 (for example) be no longer strictly demanded.
833 The solution here is a bit ad hoc...
834
835
836 %************************************************************************
837 %*                                                                      *
838 \subsection[Simplify-simplExpr]{The main function: simplExpr}
839 %*                                                                      *
840 %************************************************************************
841
842 The reason for this OutExprStuff stuff is that we want to float *after*
843 simplifying a RHS, not before.  If we do so naively we get quadratic
844 behaviour as things float out.
845
846 To see why it's important to do it after, consider this (real) example:
847
848         let t = f x
849         in fst t
850 ==>
851         let t = let a = e1
852                     b = e2
853                 in (a,b)
854         in fst t
855 ==>
856         let a = e1
857             b = e2
858             t = (a,b)
859         in
860         a       -- Can't inline a this round, cos it appears twice
861 ==>
862         e1
863
864 Each of the ==> steps is a round of simplification.  We'd save a
865 whole round if we float first.  This can cascade.  Consider
866
867         let f = g d
868         in \x -> ...f...
869 ==>
870         let f = let d1 = ..d.. in \y -> e
871         in \x -> ...f...
872 ==>
873         let d1 = ..d..
874         in \x -> ...(\y ->e)...
875
876 Only in this second round can the \y be applied, and it
877 might do the same again.
878
879
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
885         -- Simplify an expression, given a continuation
886 simplExprC env expr cont
887   = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $
888     do  { (env', expr') <- simplExprF (zapFloats env) expr cont
889         ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
890           -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
891           -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $
892           return (wrapFloats env' expr') }
893
894 --------------------------------------------------
895 simplExprF :: SimplEnv -> InExpr -> SimplCont
896            -> SimplM (SimplEnv, OutExpr)
897
898 simplExprF env e cont
899   = {- pprTrace "simplExprF" (vcat 
900       [ ppr e
901       , text "cont =" <+> ppr cont
902       , text "inscope =" <+> ppr (seInScope env)
903       , text "tvsubst =" <+> ppr (seTvSubst env)
904       , text "idsubst =" <+> ppr (seIdSubst env)
905       , text "cvsubst =" <+> ppr (seCvSubst env)
906       {- , ppr (seFloats env) -} 
907       ]) $ -}
908     simplExprF1 env e cont
909
910 simplExprF1 :: SimplEnv -> InExpr -> SimplCont
911             -> SimplM (SimplEnv, OutExpr)
912 simplExprF1 env (Var v)        cont = simplIdF env v cont
913 simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
914 simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont
915 simplExprF1 env (Cast body co) cont = simplCast env body co cont
916 simplExprF1 env (Coercion co)  cont = simplCoercionF env co cont
917 simplExprF1 env (Type ty)      cont = ASSERT( contIsRhsOrArg cont )
918                                       rebuild env (Type (substTy env ty)) cont
919 simplExprF1 env (App fun arg)  cont = simplExprF env fun $
920                                       ApplyTo NoDup arg env cont
921
922 simplExprF1 env expr@(Lam {}) cont
923   = simplLam env zapped_bndrs body cont
924         -- The main issue here is under-saturated lambdas
925         --   (\x1. \x2. e) arg1
926         -- Here x1 might have "occurs-once" occ-info, because occ-info
927         -- is computed assuming that a group of lambdas is applied
928         -- all at once.  If there are too few args, we must zap the
929         -- occ-info, UNLESS the remaining binders are one-shot
930   where
931     (bndrs, body) = collectBinders expr
932     zapped_bndrs | need_to_zap = map zap bndrs
933                  | otherwise   = bndrs
934
935     need_to_zap = any zappable_bndr (drop n_args bndrs)
936     n_args = countArgs cont
937         -- NB: countArgs counts all the args (incl type args)
938         -- and likewise drop counts all binders (incl type lambdas)
939
940     zappable_bndr b = isId b && not (isOneShotBndr b)
941     zap b | isTyVar b = b
942           | otherwise = zapLamIdInfo b
943
944 simplExprF1 env (Case scrut bndr _ alts) cont
945   | sm_case_case (getMode env)
946   =     -- Simplify the scrutinee with a Select continuation
947     simplExprF env scrut (Select NoDup bndr alts env cont)
948
949   | otherwise
950   =     -- If case-of-case is off, simply simplify the case expression
951         -- in a vanilla Stop context, and rebuild the result around it
952     do  { case_expr' <- simplExprC env scrut
953                              (Select NoDup bndr alts env mkBoringStop)
954         ; rebuild env case_expr' cont }
955
956 simplExprF1 env (Let (Rec pairs) body) cont
957   = do  { env' <- simplRecBndrs env (map fst pairs)
958                 -- NB: bndrs' don't have unfoldings or rules
959                 -- We add them as we go down
960
961         ; env'' <- simplRecBind env' NotTopLevel pairs
962         ; 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
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 simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
978                -> SimplM (SimplEnv, OutExpr)
979 -- We are simplifying a term of form (Coercion co)
980 -- Simplify the InCoercion, and then try to combine with the 
981 -- context, to implememt the rule
982 --     (Coercion co) |> g
983 --  =  Coercion (syn (nth 0 g) ; co ; nth 1 g) 
984 simplCoercionF env co cont 
985   = do { co' <- simplCoercion env co
986        ; simpl_co co' cont }
987   where
988     simpl_co co (CoerceIt g cont)
989        = simpl_co new_co cont
990      where
991        -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
992        -- g1 :: s1 ~# t1
993        -- g2 :: s2 ~# t2
994        new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2
995        [_reflk, g1, g2] = decomposeCo 3 g
996             -- Remember, (~#) :: forall k. k -> k -> *
997             -- so it takes *three* arguments, not two
998
999     simpl_co co cont
1000        = seqCo co `seq` rebuild env (Coercion co) cont
1001
1002 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
1003 simplCoercion env co
1004   = let opt_co = optCoercion (getCvSubst env) co
1005     in opt_co `seq` return opt_co
1006
1007 -----------------------------------
1008 -- | Push a TickIt context outwards past applications and cases, as
1009 -- long as this is a non-scoping tick, to let case and application
1010 -- optimisations apply.
1011
1012 simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
1013           -> SimplM (SimplEnv, OutExpr)
1014 simplTick env tickish expr cont
1015   -- A scoped tick turns into a continuation, so that we can spot
1016   -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do
1017   -- it this way, then it would take two passes of the simplifier to
1018   -- reduce ((scc t (\x . e)) e').
1019   -- NB, don't do this with counting ticks, because if the expr is
1020   -- bottom, then rebuildCall will discard the continuation.
1021
1022 -- XXX: we cannot do this, because the simplifier assumes that
1023 -- the context can be pushed into a case with a single branch. e.g.
1024 --    scc<f>  case expensive of p -> e
1025 -- becomes
1026 --    case expensive of p -> scc<f> e
1027 --
1028 -- So I'm disabling this for now.  It just means we will do more
1029 -- simplifier iterations that necessary in some cases.
1030
1031 --  | tickishScoped tickish && not (tickishCounts tickish)
1032 --  = simplExprF env expr (TickIt tickish cont)
1033
1034   -- For non-scoped ticks, we push the continuation inside the
1035   -- tick.  This has the effect of moving the tick to the outside of a
1036   -- case or application context, allowing the normal case and
1037   -- application optimisations to fire.
1038   | not (tickishScoped tickish)
1039   = do { (env', expr') <- simplExprF env expr cont
1040        ; return (env', mkTick tickish expr')
1041        }
1042
1043   -- For breakpoints, we cannot do any floating of bindings around the
1044   -- tick, because breakpoints cannot be split into tick/scope pairs.
1045   | not (tickishCanSplit tickish)
1046   = no_floating_past_tick
1047
1048   | Just expr' <- want_to_push_tick_inside
1049     -- see Note [case-of-scc-of-case]
1050   = simplExprF env expr' cont
1051
1052   | otherwise
1053   = no_floating_past_tick -- was: wrap_floats, see below
1054
1055  where
1056   want_to_push_tick_inside
1057      | not interesting_cont = Nothing
1058      | not (tickishCanSplit tickish) = Nothing
1059      | otherwise
1060        = case expr of
1061            Case scrut bndr ty alts
1062               -> Just (Case (mkTick tickish scrut) bndr ty alts')
1063              where t_scope = mkNoTick tickish -- drop the tick on the dup'd ones
1064                    alts'   = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
1065            _other -> Nothing
1066     where
1067       interesting_cont = case cont of
1068                             Select _ _ _ _ _ -> True
1069                             _ -> False
1070
1071   no_floating_past_tick =
1072     do { let (inc,outc) = splitCont cont
1073        ; (env', expr') <- simplExprF (zapFloats env) expr inc
1074        ; let tickish' = simplTickish env tickish
1075        ; (env'', expr'') <- rebuild (zapFloats env')
1076                                     (wrapFloats env' expr')
1077                                     (TickIt tickish' outc)
1078        ; return (addFloats env env'', expr'')
1079        }
1080
1081 -- Alternative version that wraps outgoing floats with the tick.  This
1082 -- results in ticks being duplicated, as we don't make any attempt to
1083 -- eliminate the tick if we re-inline the binding (because the tick
1084 -- semantics allows unrestricted inlining of HNFs), so I'm not doing
1085 -- this any more.  FloatOut will catch any real opportunities for
1086 -- floating.
1087 --
1088 --  wrap_floats =
1089 --    do { let (inc,outc) = splitCont cont
1090 --       ; (env', expr') <- simplExprF (zapFloats env) expr inc
1091 --       ; let tickish' = simplTickish env tickish
1092 --       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
1093 --                                   mkTick (mkNoTick tickish') rhs)
1094 --              -- when wrapping a float with mkTick, we better zap the Id's
1095 --              -- strictness info and arity, because it might be wrong now.
1096 --       ; let env'' = addFloats env (mapFloats env' wrap_float)
1097 --       ; rebuild env'' expr' (TickIt tickish' outc)
1098 --       }
1099
1100
1101   simplTickish env tickish
1102     | Breakpoint n ids <- tickish
1103           = Breakpoint n (map (getDoneId . substId env) ids)
1104     | otherwise = tickish
1105
1106   -- push type application and coercion inside a tick
1107   splitCont :: SimplCont -> (SimplCont, SimplCont)
1108   splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc)
1109     where (inc,outc) = splitCont c
1110   splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
1111     where (inc,outc) = splitCont c
1112   splitCont other = (mkBoringStop, other)
1113
1114   getDoneId (DoneId id) = id
1115   getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
1116   getDoneId other = pprPanic "getDoneId" (ppr other)
1117
1118 -- Note [case-of-scc-of-case]
1119 -- It's pretty important to be able to transform case-of-case when
1120 -- there's an SCC in the way.  For example, the following comes up
1121 -- in nofib/real/compress/Encode.hs:
1122 --
1123 --        case scctick<code_string.r1>
1124 --             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje
1125 --             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->
1126 --             (ww1_s13f, ww2_s13g, ww3_s13h)
1127 --             }
1128 --        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->
1129 --        tick<code_string.f1>
1130 --        (ww_s12Y,
1131 --         ww1_s12Z,
1132 --         PTTrees.PT
1133 --           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)
1134 --        }
1135 --  
1136 -- We really want this case-of-case to fire, because then the 3-tuple
1137 -- will go away (indeed, the CPR optimisation is relying on this
1138 -- happening).  But the scctick is in the way - we need to push it
1139 -- inside to expose the case-of-case.  So we perform this
1140 -- transformation on the inner case:
1141 --
1142 --   scctick c (case e of { p1 -> e1; ...; pn -> en })
1143 --    ==>
1144 --   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }
1145 --
1146 -- So we've moved a constant amount of work out of the scc to expose
1147 -- the case.  We only do this when the continuation is interesting: in
1148 -- for now, it has to be another Case (maybe generalise this later).
1149 \end{code}
1150
1151
1152 %************************************************************************
1153 %*                                                                      *
1154 \subsection{The main rebuilder}
1155 %*                                                                      *
1156 %************************************************************************
1157
1158 \begin{code}
1159 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
1160 -- At this point the substitution in the SimplEnv should be irrelevant
1161 -- only the in-scope set and floats should matter
1162 rebuild env expr cont
1163   = case cont of
1164       Stop {}                      -> return (env, expr)
1165       CoerceIt co cont             -> rebuild env (Cast expr co) cont
1166       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
1167       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
1168       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
1169                                          ; simplLam env' bs body cont }
1170       ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
1171         | isSimplified dup_flag    -> rebuild env (App expr arg) cont
1172         | otherwise                -> do { arg' <- simplExpr (se `setInScope` env) arg
1173                                          ; rebuild env (App expr arg') cont }
1174       TickIt t cont                -> rebuild env (mkTick t expr) cont
1175 \end{code}
1176
1177
1178 %************************************************************************
1179 %*                                                                      *
1180 \subsection{Lambdas}
1181 %*                                                                      *
1182 %************************************************************************
1183
1184 \begin{code}
1185 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
1186           -> SimplM (SimplEnv, OutExpr)
1187 simplCast env body co0 cont0
1188   = do  { co1 <- simplCoercion env co0
1189         ; -- pprTrace "simplCast" (ppr co1) $
1190           simplExprF env body (addCoerce co1 cont0) }
1191   where
1192        addCoerce co cont = add_coerce co (coercionKind co) cont
1193
1194        add_coerce _co (Pair s1 k1) cont     -- co :: ty~ty
1195          | s1 `eqType` k1 = cont    -- is a no-op
1196
1197        add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
1198          | (Pair _l1 t1) <- coercionKind co2
1199                 --      e |> (g1 :: S1~L) |> (g2 :: L~T1)
1200                 -- ==>
1201                 --      e,                       if S1=T1
1202                 --      e |> (g1 . g2 :: S1~T1)  otherwise
1203                 --
1204                 -- For example, in the initial form of a worker
1205                 -- we may find  (coerce T (coerce S (\x.e))) y
1206                 -- and we'd like it to simplify to e[y/x] in one round
1207                 -- of simplification
1208          , s1 `eqType` t1  = cont            -- The coerces cancel out
1209          | otherwise       = CoerceIt (mkTransCo co1 co2) cont
1210
1211        add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
1212                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
1213                 -- This implements the PushT rule from the paper
1214          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
1215          = ASSERT( isTyVar tyvar )
1216            ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
1217          where
1218            new_cast = mkInstCo co arg_ty'
1219            arg_ty' | isSimplified dup = arg_ty
1220                    | otherwise        = substTy (arg_se `setInScope` env) arg_ty
1221
1222        add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
1223          | isFunTy s1s2   -- This implements the Push rule from the paper
1224          , isFunTy t1t2   -- Check t1t2 to ensure 'arg' is a value arg
1225                 --      (e |> (g :: s1s2 ~ t1->t2)) f
1226                 -- ===>
1227                 --      (e (f |> (arg g :: t1~s1))
1228                 --      |> (res g :: s2->t2)
1229                 --
1230                 -- t1t2 must be a function type, t1->t2, because it's applied
1231                 -- to something but s1s2 might conceivably not be
1232                 --
1233                 -- When we build the ApplyTo we can't mix the out-types
1234                 -- with the InExpr in the argument, so we simply substitute
1235                 -- to make it all consistent.  It's a bit messy.
1236                 -- But it isn't a common case.
1237                 --
1238                 -- Example of use: Trac #995
1239          = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont)
1240          where
1241            -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
1242            -- t2 ~ s2 with left and right on the curried form:
1243            --    (->) t1 t2 ~ (->) s1 s2
1244            [co1, co2] = decomposeCo 2 co
1245            new_arg    = mkCoerce (mkSymCo co1) arg'
1246            arg'       = substExpr (text "move-cast") arg_se' arg
1247            arg_se'    = arg_se `setInScope` env
1248
1249        add_coerce co _ cont = CoerceIt co cont
1250 \end{code}
1251
1252
1253 %************************************************************************
1254 %*                                                                      *
1255 \subsection{Lambdas}
1256 %*                                                                      *
1257 %************************************************************************
1258
1259 Note [Zap unfolding when beta-reducing]
1260 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1261 Lambda-bound variables can have stable unfoldings, such as
1262    $j = \x. \b{Unf=Just x}. e
1263 See Note [Case binders and join points] below; the unfolding for lets
1264 us optimise e better.  However when we beta-reduce it we want to
1265 revert to using the actual value, otherwise we can end up in the
1266 stupid situation of
1267           let x = blah in
1268           let b{Unf=Just x} = y
1269           in ...b...
1270 Here it'd be far better to drop the unfolding and use the actual RHS.
1271
1272 \begin{code}
1273 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
1274          -> SimplM (SimplEnv, OutExpr)
1275
1276 simplLam env [] body cont = simplExprF env body cont
1277
1278         -- Beta reduction
1279 simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
1280   = do  { tick (BetaReduction bndr)
1281         ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
1282   where
1283     zap_unfolding bndr  -- See Note [Zap unfolding when beta-reducing]
1284       | isId bndr, isStableUnfolding (realIdUnfolding bndr)
1285       = setIdUnfolding bndr NoUnfolding
1286       | otherwise = bndr
1287
1288       -- discard a non-counting tick on a lambda.  This may change the
1289       -- cost attribution slightly (moving the allocation of the
1290       -- lambda elsewhere), but we don't care: optimisation changes
1291       -- cost attribution all the time.
1292 simplLam env bndrs body (TickIt tickish cont)
1293   | not (tickishCounts tickish)
1294   = simplLam env bndrs body cont
1295
1296         -- Not enough args, so there are real lambdas left to put in the result
1297 simplLam env bndrs body cont
1298   = do  { (env', bndrs') <- simplLamBndrs env bndrs
1299         ; body' <- simplExpr env' body
1300         ; new_lam <- mkLam env' bndrs' body'
1301         ; rebuild env' new_lam cont }
1302
1303 ------------------
1304 simplNonRecE :: SimplEnv
1305              -> InBndr                  -- The binder
1306              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
1307              -> ([InBndr], InExpr)      -- Body of the let/lambda
1308                                         --      \xs.e
1309              -> SimplCont
1310              -> SimplM (SimplEnv, OutExpr)
1311
1312 -- simplNonRecE is used for
1313 --  * non-top-level non-recursive lets in expressions
1314 --  * beta reduction
1315 --
1316 -- It deals with strict bindings, via the StrictBind continuation,
1317 -- which may abort the whole process
1318 --
1319 -- The "body" of the binding comes as a pair of ([InId],InExpr)
1320 -- representing a lambda; so we recurse back to simplLam
1321 -- Why?  Because of the binder-occ-info-zapping done before
1322 --       the call to simplLam in simplExprF (Lam ...)
1323
1324         -- First deal with type applications and type lets
1325         --   (/\a. e) (Type ty)   and   (let a = Type ty in e)
1326 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
1327   = ASSERT( isTyVar bndr )
1328     do  { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
1329         ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
1330
1331 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
1332   | preInlineUnconditionally env NotTopLevel bndr rhs
1333   = do  { tick (PreInlineUnconditionally bndr)
1334         ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
1335           simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
1336
1337   | isStrictId bndr              -- Includes coercions
1338   = do  { simplExprF (rhs_se `setFloats` env) rhs
1339                      (StrictBind bndr bndrs body env cont) }
1340
1341   | otherwise
1342   = ASSERT( not (isTyVar bndr) )
1343     do  { (env1, bndr1) <- simplNonRecBndr env bndr
1344         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
1345         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
1346         ; simplLam env3 bndrs body cont }
1347 \end{code}
1348
1349 %************************************************************************
1350 %*                                                                      *
1351                      Variables
1352 %*                                                                      *
1353 %************************************************************************
1354
1355 \begin{code}
1356 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
1357 -- Look up an InVar in the environment
1358 simplVar env var
1359   | isTyVar var = return (Type (substTyVar env var))
1360   | isCoVar var = return (Coercion (substCoVar env var))
1361   | otherwise
1362   = case substId env var of
1363         DoneId var1          -> return (Var var1)
1364         DoneEx e             -> return e
1365         ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
1366
1367 simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
1368 simplIdF env var cont
1369   = case substId env var of
1370         DoneEx e             -> simplExprF (zapSubstEnv env) e cont
1371         ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
1372         DoneId var1          -> completeCall env var1 cont
1373                 -- Note [zapSubstEnv]
1374                 -- The template is already simplified, so don't re-substitute.
1375                 -- This is VITAL.  Consider
1376                 --      let x = e in
1377                 --      let y = \z -> ...x... in
1378                 --      \ x -> ...y...
1379                 -- We'll clone the inner \x, adding x->x' in the id_subst
1380                 -- Then when we inline y, we must *not* replace x by x' in
1381                 -- the inlined copy!!
1382
1383 ---------------------------------------------------------
1384 --      Dealing with a call site
1385
1386 completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
1387 completeCall env var cont
1388   = do  {   ------------- Try inlining ----------------
1389           dflags <- getDOptsSmpl
1390         ; let  (lone_variable, arg_infos, call_cont) = contArgs cont
1391                 -- The args are OutExprs, obtained by *lazily* substituting
1392                 -- in the args found in cont.  These args are only examined
1393                 -- to limited depth (unless a rule fires).  But we must do
1394                 -- the substitution; rule matching on un-simplified args would
1395                 -- be bogus
1396
1397                n_val_args = length arg_infos
1398                interesting_cont = interestingCallContext call_cont
1399                unfolding    = activeUnfolding env var
1400                maybe_inline = callSiteInline dflags var unfolding
1401                                              lone_variable arg_infos interesting_cont
1402         ; case maybe_inline of {
1403             Just expr      -- There is an inlining!
1404               ->  do { checkedTick (UnfoldingDone var)
1405                      ; trace_inline dflags expr cont $
1406                        simplExprF (zapSubstEnv env) expr cont }
1407
1408             ; Nothing -> do               -- No inlining!
1409
1410         { rule_base <- getSimplRules
1411         ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
1412         ; rebuildCall env info cont
1413     }}}
1414   where
1415     trace_inline dflags unfolding cont stuff
1416       | not (dopt Opt_D_dump_inlinings dflags) = stuff
1417       | not (dopt Opt_D_verbose_core2core dflags) 
1418       = if isExternalName (idName var) then 
1419           pprDefiniteTrace "Inlining done:" (ppr var) stuff
1420         else stuff
1421       | otherwise
1422       = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))
1423            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
1424                   text "Cont:  " <+> ppr cont])
1425            stuff
1426
1427 rebuildCall :: SimplEnv
1428             -> ArgInfo
1429             -> SimplCont
1430             -> SimplM (SimplEnv, OutExpr)
1431 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
1432   -- When we run out of strictness args, it means
1433   -- that the call is definitely bottom; see SimplUtils.mkArgInfo
1434   -- Then we want to discard the entire strict continuation.  E.g.
1435   --    * case (error "hello") of { ... }
1436   --    * (error "Hello") arg
1437   --    * f (error "Hello") where f is strict
1438   --    etc
1439   -- Then, especially in the first of these cases, we'd like to discard
1440   -- the continuation, leaving just the bottoming expression.  But the
1441   -- type might not be right, so we may have to add a coerce.
1442   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
1443   = return (env, mk_coerce res)  -- contination to discard, else we do it
1444   where                          -- again and again!
1445     res     = mkApps (Var fun) (reverse rev_args)
1446     res_ty  = exprType res
1447     cont_ty = contResultType env res_ty cont
1448     co      = mkUnsafeCo res_ty cont_ty
1449     mk_coerce expr | cont_ty `eqType` res_ty = expr
1450                    | otherwise = mkCoerce co expr
1451
1452 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
1453   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
1454                     else simplType (se `setInScope` env) arg_ty
1455        ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
1456
1457 rebuildCall env info@(ArgInfo { ai_encl = encl_rules
1458                               , ai_strs = str:strs, ai_discs = disc:discs })
1459             (ApplyTo dup_flag arg arg_se cont)
1460   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
1461   = rebuildCall env (addArgTo info' arg) cont
1462
1463   | str                 -- Strict argument
1464   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
1465     simplExprF (arg_se `setFloats` env) arg
1466                (StrictArg info' cci cont)
1467                 -- Note [Shadowing]
1468
1469   | otherwise                           -- Lazy argument
1470         -- DO NOT float anything outside, hence simplExprC
1471         -- There is no benefit (unlike in a let-binding), and we'd
1472         -- have to be very careful about bogus strictness through
1473         -- floating a demanded let.
1474   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
1475                              (mkLazyArgStop cci)
1476         ; rebuildCall env (addArgTo info' arg') cont }
1477   where
1478     info' = info { ai_strs = strs, ai_discs = discs }
1479     cci | encl_rules || disc > 0 = ArgCtxt encl_rules  -- Be keener here
1480         | otherwise              = BoringCtxt          -- Nothing interesting
1481
1482 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
1483   = do {  -- We've accumulated a simplified call in <fun,rev_args> 
1484           -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
1485           -- See also Note [Rules for recursive functions]
1486         ; let args = reverse rev_args
1487               env' = zapSubstEnv env
1488         ; mb_rule <- tryRules env rules fun args cont
1489         ; case mb_rule of {
1490              Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $
1491                                         pushSimplifiedArgs env' (drop n_args args) cont ;
1492                  -- n_args says how many args the rule consumed
1493            ; Nothing -> rebuild env (mkApps (Var fun) args) cont      -- No rules
1494     } }
1495 \end{code}
1496
1497 Note [RULES apply to simplified arguments]
1498 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1499 It's very desirable to try RULES once the arguments have been simplified, because
1500 doing so ensures that rule cascades work in one pass.  Consider
1501    {-# RULES g (h x) = k x
1502              f (k x) = x #-}
1503    ...f (g (h x))...
1504 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
1505 we match f's rules against the un-simplified RHS, it won't match.  This 
1506 makes a particularly big difference when superclass selectors are involved:
1507         op ($p1 ($p2 (df d)))
1508 We want all this to unravel in one sweeep.
1509
1510 Note [Avoid redundant simplification]
1511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1512 Because RULES apply to simplified arguments, there's a danger of repeatedly
1513 simplifying already-simplified arguments.  An important example is that of
1514             (>>=) d e1 e2
1515 Here e1, e2 are simplified before the rule is applied, but don't really
1516 participate in the rule firing. So we mark them as Simplified to avoid
1517 re-simplifying them.
1518
1519 Note [Shadowing]
1520 ~~~~~~~~~~~~~~~~
1521 This part of the simplifier may break the no-shadowing invariant
1522 Consider
1523         f (...(\a -> e)...) (case y of (a,b) -> e')
1524 where f is strict in its second arg
1525 If we simplify the innermost one first we get (...(\a -> e)...)
1526 Simplifying the second arg makes us float the case out, so we end up with
1527         case y of (a,b) -> f (...(\a -> e)...) e'
1528 So the output does not have the no-shadowing invariant.  However, there is
1529 no danger of getting name-capture, because when the first arg was simplified
1530 we used an in-scope set that at least mentioned all the variables free in its
1531 static environment, and that is enough.
1532
1533 We can't just do innermost first, or we'd end up with a dual problem:
1534         case x of (a,b) -> f e (...(\a -> e')...)
1535
1536 I spent hours trying to recover the no-shadowing invariant, but I just could
1537 not think of an elegant way to do it.  The simplifier is already knee-deep in
1538 continuations.  We have to keep the right in-scope set around; AND we have
1539 to get the effect that finding (error "foo") in a strict arg position will
1540 discard the entire application and replace it with (error "foo").  Getting
1541 all this at once is TOO HARD!
1542
1543
1544 %************************************************************************
1545 %*                                                                      *
1546                 Rewrite rules
1547 %*                                                                      *
1548 %************************************************************************
1549
1550 \begin{code}
1551 tryRules :: SimplEnv -> [CoreRule]
1552          -> Id -> [OutExpr] -> SimplCont 
1553          -> SimplM (Maybe (Arity, CoreExpr))         -- The arity is the number of
1554                                                      -- args consumed by the rule
1555 tryRules env rules fn args call_cont
1556   | null rules
1557   = return Nothing
1558   | otherwise
1559   = do { case lookupRule (activeRule env) (getUnfoldingInRuleMatch env) 
1560                          (getInScope env) fn args rules of {
1561            Nothing               -> return Nothing ;   -- No rule matches
1562            Just (rule, rule_rhs) ->
1563
1564              do { checkedTick (RuleFired (ru_name rule))
1565                 ; dflags <- getDOptsSmpl
1566                 ; trace_dump dflags rule rule_rhs $
1567                   return (Just (ruleArity rule, rule_rhs)) }}}
1568   where
1569     trace_dump dflags rule rule_rhs stuff
1570       | not (dopt Opt_D_dump_rule_firings dflags)
1571       , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
1572
1573       | not (dopt Opt_D_dump_rule_rewrites dflags)
1574       = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff
1575
1576       | otherwise
1577       = pprDefiniteTrace "Rule fired"
1578            (vcat [text "Rule:" <+> ftext (ru_name rule),
1579                   text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
1580                   text "After: " <+> pprCoreExpr rule_rhs,
1581                   text "Cont:  " <+> ppr call_cont])
1582            stuff
1583 \end{code}
1584
1585 Note [Rules for recursive functions]
1586 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1587 You might think that we shouldn't apply rules for a loop breaker:
1588 doing so might give rise to an infinite loop, because a RULE is
1589 rather like an extra equation for the function:
1590      RULE:           f (g x) y = x+y
1591      Eqn:            f a     y = a-y
1592
1593 But it's too drastic to disable rules for loop breakers.
1594 Even the foldr/build rule would be disabled, because foldr
1595 is recursive, and hence a loop breaker:
1596      foldr k z (build g) = g k z
1597 So it's up to the programmer: rules can cause divergence
1598
1599
1600 %************************************************************************
1601 %*                                                                      *
1602                 Rebuilding a case expression
1603 %*                                                                      *
1604 %************************************************************************
1605
1606 Note [Case elimination]
1607 ~~~~~~~~~~~~~~~~~~~~~~~
1608 The case-elimination transformation discards redundant case expressions.
1609 Start with a simple situation:
1610
1611         case x# of      ===>   let y# = x# in e
1612           y# -> e
1613
1614 (when x#, y# are of primitive type, of course).  We can't (in general)
1615 do this for algebraic cases, because we might turn bottom into
1616 non-bottom!
1617
1618 The code in SimplUtils.prepareAlts has the effect of generalise this
1619 idea to look for a case where we're scrutinising a variable, and we
1620 know that only the default case can match.  For example:
1621
1622         case x of
1623           0#      -> ...
1624           DEFAULT -> ...(case x of
1625                          0#      -> ...
1626                          DEFAULT -> ...) ...
1627
1628 Here the inner case is first trimmed to have only one alternative, the
1629 DEFAULT, after which it's an instance of the previous case.  This
1630 really only shows up in eliminating error-checking code.
1631
1632 Note that SimplUtils.mkCase combines identical RHSs.  So
1633
1634         case e of       ===> case e of DEFAULT -> r
1635            True  -> r
1636            False -> r
1637
1638 Now again the case may be elminated by the CaseElim transformation.
1639 This includes things like (==# a# b#)::Bool so that we simplify
1640       case ==# a# b# of { True -> x; False -> x }
1641 to just
1642       x
1643 This particular example shows up in default methods for
1644 comparision operations (e.g. in (>=) for Int.Int32)
1645
1646 Note [Case elimination: lifted case]
1647 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1648 We also make sure that we deal with this very common case,
1649 where x has a lifted type:
1650
1651         case e of
1652           x -> ...x...
1653
1654 Here we are using the case as a strict let; if x is used only once
1655 then we want to inline it.  We have to be careful that this doesn't
1656 make the program terminate when it would have diverged before, so we
1657 check that
1658         (a) 'e' is already evaluated (it may so if e is a variable)
1659             Specifically we check (exprIsHNF e)
1660 or
1661         (b) the scrutinee is a variable and 'x' is used strictly
1662 or
1663         (c) 'x' is not used at all and e is ok-for-speculation
1664
1665 For the (c), consider
1666    case (case a ># b of { True -> (p,q); False -> (q,p) }) of
1667      r -> blah
1668 The scrutinee is ok-for-speculation (it looks inside cases), but we do
1669 not want to transform to
1670    let r = case a ># b of { True -> (p,q); False -> (q,p) }
1671    in blah
1672 because that builds an unnecessary thunk.
1673
1674
1675 Further notes about case elimination
1676 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1677 Consider:       test :: Integer -> IO ()
1678                 test = print
1679
1680 Turns out that this compiles to:
1681     Print.test
1682       = \ eta :: Integer
1683           eta1 :: State# RealWorld ->
1684           case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
1685           case hPutStr stdout
1686                  (PrelNum.jtos eta ($w[] @ Char))
1687                  eta1
1688           of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
1689
1690 Notice the strange '<' which has no effect at all. This is a funny one.
1691 It started like this:
1692
1693 f x y = if x < 0 then jtos x
1694           else if y==0 then "" else jtos x
1695
1696 At a particular call site we have (f v 1).  So we inline to get
1697
1698         if v < 0 then jtos x
1699         else if 1==0 then "" else jtos x
1700
1701 Now simplify the 1==0 conditional:
1702
1703         if v<0 then jtos v else jtos v
1704
1705 Now common-up the two branches of the case:
1706
1707         case (v<0) of DEFAULT -> jtos v
1708
1709 Why don't we drop the case?  Because it's strict in v.  It's technically
1710 wrong to drop even unnecessary evaluations, and in practice they
1711 may be a result of 'seq' so we *definitely* don't want to drop those.
1712 I don't really know how to improve this situation.
1713
1714 \begin{code}
1715 ---------------------------------------------------------
1716 --      Eliminate the case if possible
1717
1718 rebuildCase, reallyRebuildCase
1719    :: SimplEnv
1720    -> OutExpr          -- Scrutinee
1721    -> InId             -- Case binder
1722    -> [InAlt]          -- Alternatives (inceasing order)
1723    -> SimplCont
1724    -> SimplM (SimplEnv, OutExpr)
1725
1726 --------------------------------------------------
1727 --      1. Eliminate the case if there's a known constructor
1728 --------------------------------------------------
1729
1730 rebuildCase env scrut case_bndr alts cont
1731   | Lit lit <- scrut    -- No need for same treatment as constructors
1732                         -- because literals are inlined more vigorously
1733   , not (litIsLifted lit)
1734   = do  { tick (KnownBranch case_bndr)
1735         ; case findAlt (LitAlt lit) alts of
1736             Nothing           -> missingAlt env case_bndr alts cont
1737             Just (_, bs, rhs) -> simple_rhs bs rhs }
1738
1739   | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
1740         -- Works when the scrutinee is a variable with a known unfolding
1741         -- as well as when it's an explicit constructor application
1742   = do  { tick (KnownBranch case_bndr)
1743         ; case findAlt (DataAlt con) alts of
1744             Nothing  -> missingAlt env case_bndr alts cont
1745             Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
1746             Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args 
1747                                                 case_bndr bs rhs cont
1748         }
1749   where
1750     simple_rhs bs rhs = ASSERT( null bs ) 
1751                         do { env' <- simplNonRecX env case_bndr scrut
1752                            ; simplExprF env' rhs cont }
1753
1754
1755 --------------------------------------------------
1756 --      2. Eliminate the case if scrutinee is evaluated
1757 --------------------------------------------------
1758
1759 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
1760   -- See if we can get rid of the case altogether
1761   -- See Note [Case elimination] 
1762   -- mkCase made sure that if all the alternatives are equal,
1763   -- then there is now only one (DEFAULT) rhs
1764  | all isDeadBinder bndrs       -- bndrs are [InId]
1765
1766  , if isUnLiftedType (idType case_bndr)
1767    then ok_for_spec         -- Satisfy the let-binding invariant
1768    else elim_lifted
1769   = do  { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut),
1770           --                            ppr strict_case_bndr, ppr (scrut_is_var scrut),
1771           --                            ppr ok_for_spec,
1772           --                            ppr scrut]) $
1773           tick (CaseElim case_bndr)
1774         ; env' <- simplNonRecX env case_bndr scrut
1775           -- If case_bndr is deads, simplNonRecX will discard
1776         ; simplExprF env' rhs cont }
1777   where
1778     elim_lifted   -- See Note [Case elimination: lifted case]
1779       = exprIsHNF scrut
1780      || (strict_case_bndr && scrut_is_var scrut) 
1781               -- The case binder is going to be evaluated later,
1782               -- and the scrutinee is a simple variable
1783
1784      || (is_plain_seq && ok_for_spec)
1785               -- Note: not the same as exprIsHNF
1786
1787     ok_for_spec      = exprOkForSpeculation scrut
1788     is_plain_seq     = isDeadBinder case_bndr   -- Evaluation *only* for effect
1789     strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)
1790
1791     scrut_is_var (Cast s _) = scrut_is_var s
1792     scrut_is_var (Var _)    = True
1793     scrut_is_var _          = False
1794
1795
1796 --------------------------------------------------
1797 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
1798 --------------------------------------------------
1799
1800 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
1801   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
1802   = do { let rhs' = substExpr (text "rebuild-case") env rhs
1803              out_args = [Type (substTy env (idType case_bndr)), 
1804                          Type (exprType rhs'), scrut, rhs']
1805                       -- Lazily evaluated, so we don't do most of this
1806
1807        ; rule_base <- getSimplRules
1808        ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont
1809        ; case mb_rule of 
1810            Just (n_args, res) -> simplExprF (zapSubstEnv env) 
1811                                             (mkApps res (drop n_args out_args))
1812                                             cont
1813            Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
1814
1815 rebuildCase env scrut case_bndr alts cont
1816   = reallyRebuildCase env scrut case_bndr alts cont
1817
1818 --------------------------------------------------
1819 --      3. Catch-all case
1820 --------------------------------------------------
1821
1822 reallyRebuildCase env scrut case_bndr alts cont
1823   = do  {       -- Prepare the continuation;
1824                 -- The new subst_env is in place
1825           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
1826
1827         -- Simplify the alternatives
1828         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
1829
1830         -- Check for empty alternatives
1831         ; if null alts' then missingAlt env case_bndr alts cont
1832           else do
1833         { dflags <- getDOptsSmpl
1834         ; case_expr <- mkCase dflags scrut' case_bndr' alts'
1835
1836         -- Notice that rebuild gets the in-scope set from env', not alt_env
1837         -- (which in any case is only build in simplAlts)
1838         -- The case binder *not* scope over the whole returned case-expression
1839         ; rebuild env' case_expr nodup_cont } }
1840 \end{code}
1841
1842 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
1843 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1844 way, there's a chance that v will now only be used once, and hence
1845 inlined.
1846
1847 Historical note: we use to do the "case binder swap" in the Simplifier
1848 so there were additional complications if the scrutinee was a variable.
1849 Now the binder-swap stuff is done in the occurrence analyer; see
1850 OccurAnal Note [Binder swap].
1851
1852 Note [zapOccInfo]
1853 ~~~~~~~~~~~~~~~~~
1854 If the case binder is not dead, then neither are the pattern bound
1855 variables:  
1856         case <any> of x { (a,b) ->
1857         case x of { (p,q) -> p } }
1858 Here (a,b) both look dead, but come alive after the inner case is eliminated.
1859 The point is that we bring into the envt a binding
1860         let x = (a,b)
1861 after the outer case, and that makes (a,b) alive.  At least we do unless
1862 the case binder is guaranteed dead.
1863
1864 In practice, the scrutinee is almost always a variable, so we pretty
1865 much always zap the OccInfo of the binders.  It doesn't matter much though.
1866
1867 Note [Improving seq]
1868 ~~~~~~~~~~~~~~~~~~~
1869 Consider
1870         type family F :: * -> *
1871         type instance F Int = Int
1872
1873         ... case e of x { DEFAULT -> rhs } ...
1874
1875 where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
1876
1877         case e `cast` co of x'::Int
1878            I# x# -> let x = x' `cast` sym co
1879                     in rhs
1880
1881 so that 'rhs' can take advantage of the form of x'.  
1882
1883 Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. 
1884
1885 Nota Bene: We only do the [Improving seq] transformation if the 
1886 case binder 'x' is actually used in the rhs; that is, if the case 
1887 is *not* a *pure* seq.  
1888   a) There is no point in adding the cast to a pure seq.
1889   b) There is a good reason not to: doing so would interfere 
1890      with seq rules (Note [Built-in RULES for seq] in MkId).
1891      In particular, this [Improving seq] thing *adds* a cast
1892      while [Built-in RULES for seq] *removes* one, so they
1893      just flip-flop.
1894
1895 You might worry about 
1896    case v of x { __DEFAULT ->
1897       ... case (v `cast` co) of y { I# -> ... }}
1898 This is a pure seq (since x is unused), so [Improving seq] won't happen.
1899 But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
1900    case v of x { __DEFAULT ->
1901       ... case (x `cast` co) of y { I# -> ... }}
1902 Now the outer case is not a pure seq, so [Improving seq] will happen,
1903 and then the inner case will disappear.
1904
1905 The need for [Improving seq] showed up in Roman's experiments.  Example:
1906   foo :: F Int -> Int -> Int
1907   foo t n = t `seq` bar n
1908      where
1909        bar 0 = 0
1910        bar n = bar (n - case t of TI i -> i)
1911 Here we'd like to avoid repeated evaluating t inside the loop, by
1912 taking advantage of the `seq`.
1913
1914 At one point I did transformation in LiberateCase, but it's more
1915 robust here.  (Otherwise, there's a danger that we'll simply drop the
1916 'seq' altogether, before LiberateCase gets to see it.)
1917
1918 \begin{code}
1919 simplAlts :: SimplEnv
1920           -> OutExpr
1921           -> InId                       -- Case binder
1922           -> [InAlt]                    -- Non-empty
1923           -> SimplCont
1924           -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
1925 -- Like simplExpr, this just returns the simplified alternatives;
1926 -- it does not return an environment
1927
1928 simplAlts env scrut case_bndr alts cont'
1929   = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $
1930     do  { let env0 = zapFloats env
1931
1932         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
1933
1934         ; fam_envs <- getFamEnvs
1935         ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut 
1936                                                        case_bndr case_bndr1 alts
1937
1938         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
1939
1940         ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
1941         ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
1942                              imposs_deflt_cons case_bndr' cont') in_alts
1943         ; return (scrut', case_bndr', alts') }
1944
1945
1946 ------------------------------------
1947 improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
1948            -> OutExpr -> InId -> OutId -> [InAlt]
1949            -> SimplM (SimplEnv, OutExpr, OutId)
1950 -- Note [Improving seq]
1951 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
1952   | not (isDeadBinder case_bndr)        -- Not a pure seq!  See Note [Improving seq]
1953   , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
1954   = do { case_bndr2 <- newId (fsLit "nt") ty2
1955         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
1956               env2 = extendIdSubst env case_bndr rhs
1957         ; return (env2, scrut `Cast` co, case_bndr2) }
1958
1959 improveSeq _ env scrut _ case_bndr1 _
1960   = return (env, scrut, case_bndr1)
1961
1962
1963 ------------------------------------
1964 simplAlt :: SimplEnv
1965          -> Maybe OutId    -- Scrutinee
1966          -> [AltCon]       -- These constructors can't be present when
1967                            -- matching the DEFAULT alternative
1968          -> OutId          -- The case binder
1969          -> SimplCont
1970          -> InAlt
1971          -> SimplM OutAlt
1972
1973 simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
1974   = ASSERT( null bndrs )
1975     do  { let env' = addBinderUnfolding env scrut case_bndr' 
1976                                         (mkOtherCon imposs_deflt_cons)
1977                 -- Record the constructors that the case-binder *can't* be.
1978         ; rhs' <- simplExprC env' rhs cont'
1979         ; return (DEFAULT, [], rhs') }
1980
1981 simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
1982   = ASSERT( null bndrs )
1983     do  { let env' = addBinderUnfolding env scrut case_bndr' 
1984                                         (mkSimpleUnfolding (Lit lit))
1985         ; rhs' <- simplExprC env' rhs cont'
1986         ; return (LitAlt lit, [], rhs') }
1987
1988 simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)
1989   = do  {       -- Deal with the pattern-bound variables
1990                 -- Mark the ones that are in ! positions in the
1991                 -- data constructor as certainly-evaluated.
1992                 -- NB: simplLamBinders preserves this eval info
1993           let vs_with_evals = add_evals (dataConRepStrictness con)
1994         ; (env', vs') <- simplLamBndrs env vs_with_evals
1995
1996                 -- Bind the case-binder to (con args)
1997         ; let inst_tys' = tyConAppArgs (idType case_bndr')
1998               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'
1999               unf       = mkSimpleUnfolding (mkConApp con con_args)
2000               env''     = addBinderUnfolding env' scrut case_bndr' unf
2001
2002         ; rhs' <- simplExprC env'' rhs cont'
2003         ; return (DataAlt con, vs', rhs') }
2004   where
2005         -- add_evals records the evaluated-ness of the bound variables of
2006         -- a case pattern.  This is *important*.  Consider
2007         --      data T = T !Int !Int
2008         --
2009         --      case x of { T a b -> T (a+1) b }
2010         --
2011         -- We really must record that b is already evaluated so that we don't
2012         -- go and re-evaluate it when constructing the result.
2013         -- See Note [Data-con worker strictness] in MkId.lhs
2014     add_evals the_strs
2015         = go vs the_strs
2016         where
2017           go [] [] = []
2018           go (v:vs') strs | isTyVar v = v : go vs' strs
2019           go (v:vs') (str:strs)
2020             | isMarkedStrict str = evald_v  : go vs' strs
2021             | otherwise          = zapped_v : go vs' strs
2022             where
2023               zapped_v = zapBndrOccInfo keep_occ_info v
2024               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
2025           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
2026
2027         -- See Note [zapOccInfo]
2028         -- zap_occ_info: if the case binder is alive, then we add the unfolding
2029         --      case_bndr = C vs
2030         -- to the envt; so vs are now very much alive
2031         -- Note [Aug06] I can't see why this actually matters, but it's neater
2032         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
2033         --   ==>  case e of t { (a,b) -> ...(a)... }
2034         -- Look, Ma, a is alive now.
2035     keep_occ_info = isDeadBinder case_bndr' && isNothing scrut
2036
2037 addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv
2038 addBinderUnfolding env scrut bndr unf
2039   = case scrut of
2040        Just v -> modifyInScope env1 (v `setIdUnfolding` unf)
2041        _      -> env1
2042   where
2043     env1 = modifyInScope env bndr_w_unf
2044     bndr_w_unf = bndr `setIdUnfolding` unf
2045
2046 zapBndrOccInfo :: Bool -> Id -> Id
2047 -- Consider  case e of b { (a,b) -> ... }
2048 -- Then if we bind b to (a,b) in "...", and b is not dead,
2049 -- then we must zap the deadness info on a,b
2050 zapBndrOccInfo keep_occ_info pat_id
2051   | keep_occ_info = pat_id
2052   | otherwise     = zapIdOccInfo pat_id
2053 \end{code}
2054
2055 Note [Add unfolding for scrutinee]
2056 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2057 In general it's unlikely that a variable scrutinee will appear 
2058 in the case alternatives   case x of { ...x unlikely to appear... }
2059 because the binder-swap in OccAnal has got rid of all such occcurrences
2060 See Note [Binder swap] in OccAnal.
2061
2062 BUT it is still VERY IMPORTANT to add a suitable unfolding for a
2063 variable scrutinee, in simplAlt.  Here's why
2064    case x of y
2065      (a,b) -> case b of c
2066                 I# v -> ...(f y)...
2067 There is no occurrence of 'b' in the (...(f y)...).  But y gets
2068 the unfolding (a,b), and *that* mentions b.  If f has a RULE
2069     RULE f (p, I# q) = ...
2070 we want that rule to match, so we must extend the in-scope env with a
2071 suitable unfolding for 'y'.  It's *essential* for rule matching; but
2072 it's also good for case-elimintation -- suppose that 'f' was inlined
2073 and did multi-level case analysis, then we'd solve it in one
2074 simplifier sweep instead of two.
2075
2076 Exactly the same issue arises in SpecConstr; 
2077 see Note [Add scrutinee to ValueEnv too] in SpecConstr
2078
2079 %************************************************************************
2080 %*                                                                      *
2081 \subsection{Known constructor}
2082 %*                                                                      *
2083 %************************************************************************
2084
2085 We are a bit careful with occurrence info.  Here's an example
2086
2087         (\x* -> case x of (a*, b) -> f a) (h v, e)
2088
2089 where the * means "occurs once".  This effectively becomes
2090         case (h v, e) of (a*, b) -> f a)
2091 and then
2092         let a* = h v; b = e in f a
2093 and then
2094         f (h v)
2095
2096 All this should happen in one sweep.
2097
2098 \begin{code}
2099 knownCon :: SimplEnv            
2100          -> OutExpr                             -- The scrutinee
2101          -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
2102          -> InId -> [InBndr] -> InExpr          -- The alternative
2103          -> SimplCont
2104          -> SimplM (SimplEnv, OutExpr)
2105
2106 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
2107   = do  { env'  <- bind_args env bs dc_args
2108         ; env'' <- bind_case_bndr env'
2109         ; simplExprF env'' rhs cont }
2110   where
2111     zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
2112
2113                   -- Ugh!
2114     bind_args env' [] _  = return env'
2115
2116     bind_args env' (b:bs') (Type ty : args)
2117       = ASSERT( isTyVar b )
2118         bind_args (extendTvSubst env' b ty) bs' args
2119
2120     bind_args env' (b:bs') (arg : args)
2121       = ASSERT( isId b )
2122         do { let b' = zap_occ b
2123              -- Note that the binder might be "dead", because it doesn't
2124              -- occur in the RHS; and simplNonRecX may therefore discard
2125              -- it via postInlineUnconditionally.
2126              -- Nevertheless we must keep it if the case-binder is alive,
2127              -- because it may be used in the con_app.  See Note [zapOccInfo]
2128            ; env'' <- simplNonRecX env' b' arg
2129            ; bind_args env'' bs' args }
2130
2131     bind_args _ _ _ =
2132       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
2133                              text "scrut:" <+> ppr scrut
2134
2135        -- It's useful to bind bndr to scrut, rather than to a fresh
2136        -- binding      x = Con arg1 .. argn
2137        -- because very often the scrut is a variable, so we avoid
2138        -- creating, and then subsequently eliminating, a let-binding
2139        -- BUT, if scrut is a not a variable, we must be careful
2140        -- about duplicating the arg redexes; in that case, make
2141        -- a new con-app from the args
2142     bind_case_bndr env
2143       | isDeadBinder bndr   = return env
2144       | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut))
2145       | otherwise           = do { dc_args <- mapM (simplVar env) bs
2146                                          -- dc_ty_args are aready OutTypes, 
2147                                          -- but bs are InBndrs
2148                                  ; let con_app = Var (dataConWorkId dc) 
2149                                                  `mkTyApps` dc_ty_args      
2150                                                  `mkApps`   dc_args
2151                                  ; simplNonRecX env bndr con_app }
2152   
2153 -------------------
2154 missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
2155                 -- This isn't strictly an error, although it is unusual. 
2156                 -- It's possible that the simplifer might "see" that 
2157                 -- an inner case has no accessible alternatives before 
2158                 -- it "sees" that the entire branch of an outer case is 
2159                 -- inaccessible.  So we simply put an error case here instead.
2160 missingAlt env case_bndr alts cont
2161   = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
2162     return (env, mkImpossibleExpr res_ty)
2163   where
2164     res_ty = contResultType env (substTy env (coreAltsType alts)) cont
2165 \end{code}
2166
2167
2168 %************************************************************************
2169 %*                                                                      *
2170 \subsection{Duplicating continuations}
2171 %*                                                                      *
2172 %************************************************************************
2173
2174 \begin{code}
2175 prepareCaseCont :: SimplEnv
2176                 -> [InAlt] -> SimplCont
2177                 -> SimplM (SimplEnv, SimplCont, SimplCont)
2178 -- We are considering
2179 --     K[case _ of { p1 -> r1; ...; pn -> rn }] 
2180 -- where K is some enclosing continuation for the case
2181 -- Goal: split K into two pieces Kdup,Knodup so that
2182 --       a) Kdup can be duplicated
2183 --       b) Knodup[Kdup[e]] = K[e]
2184 -- The idea is that we'll transform thus:
2185 --          Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
2186 --
2187 -- We also return some extra bindings in SimplEnv (that scope over 
2188 -- the entire continuation)
2189
2190 prepareCaseCont env alts cont 
2191   | many_alts alts = mkDupableCont env cont 
2192   | otherwise      = return (env, cont, mkBoringStop)
2193   where
2194     many_alts :: [InAlt] -> Bool  -- True iff strictly > 1 non-bottom alternative
2195     many_alts []  = False         -- See Note [Bottom alternatives]
2196     many_alts [_] = False
2197     many_alts (alt:alts) 
2198       | is_bot_alt alt = many_alts alts   
2199       | otherwise      = not (all is_bot_alt alts)
2200   
2201     is_bot_alt (_,_,rhs) = exprIsBottom rhs
2202 \end{code}
2203
2204 Note [Bottom alternatives]
2205 ~~~~~~~~~~~~~~~~~~~~~~~~~~
2206 When we have
2207      case (case x of { A -> error .. ; B -> e; C -> error ..) 
2208        of alts
2209 then we can just duplicate those alts because the A and C cases
2210 will disappear immediately.  This is more direct than creating
2211 join points and inlining them away; and in some cases we would
2212 not even create the join points (see Note [Single-alternative case])
2213 and we would keep the case-of-case which is silly.  See Trac #4930.
2214
2215 \begin{code}
2216 mkDupableCont :: SimplEnv -> SimplCont
2217               -> SimplM (SimplEnv, SimplCont, SimplCont)
2218
2219 mkDupableCont env cont
2220   | contIsDupable cont
2221   = return (env, cont, mkBoringStop)
2222
2223 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
2224
2225 mkDupableCont env (CoerceIt ty cont)
2226   = do  { (env', dup, nodup) <- mkDupableCont env cont
2227         ; return (env', CoerceIt ty dup, nodup) }
2228
2229 -- Duplicating ticks for now, not sure if this is good or not
2230 mkDupableCont env cont@(TickIt{})
2231   = return (env, mkBoringStop, cont)
2232
2233 mkDupableCont env cont@(StrictBind {})
2234   =  return (env, mkBoringStop, cont)
2235         -- See Note [Duplicating StrictBind]
2236
2237 mkDupableCont env (StrictArg info cci cont)
2238         -- See Note [Duplicating StrictArg]
2239   = do { (env', dup, nodup) <- mkDupableCont env cont
2240        ; (env'', args')     <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info)
2241        ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
2242
2243 mkDupableCont env (ApplyTo _ arg se cont)
2244   =     -- e.g.         [...hole...] (...arg...)
2245         --      ==>
2246         --              let a = ...arg...
2247         --              in [...hole...] a
2248     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
2249         ; arg' <- simplExpr (se `setInScope` env') arg
2250         ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
2251         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
2252         ; return (env'', app_cont, nodup_cont) }
2253
2254 mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
2255 --  See Note [Single-alternative case]
2256 --  | not (exprIsDupable rhs && contIsDupable case_cont)
2257 --  | not (isDeadBinder case_bndr)
2258   | all isDeadBinder bs  -- InIds
2259     && not (isUnLiftedType (idType case_bndr))
2260     -- Note [Single-alternative-unlifted]
2261   = return (env, mkBoringStop, cont)
2262
2263 mkDupableCont env (Select _ case_bndr alts se cont)
2264   =     -- e.g.         (case [...hole...] of { pi -> ei })
2265         --      ===>
2266         --              let ji = \xij -> ei
2267         --              in case [...hole...] of { pi -> ji xij }
2268     do  { tick (CaseOfCase case_bndr)
2269         ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
2270                 -- NB: We call prepareCaseCont here.  If there is only one
2271                 -- alternative, then dup_cont may be big, but that's ok
2272                 -- becuase we push it into the single alternative, and then
2273                 -- use mkDupableAlt to turn that simplified alternative into
2274                 -- a join point if it's too big to duplicate.
2275                 -- And this is important: see Note [Fusing case continuations]
2276
2277         ; let alt_env = se `setInScope` env'
2278         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
2279         ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
2280         -- Safe to say that there are no handled-cons for the DEFAULT case
2281                 -- NB: simplBinder does not zap deadness occ-info, so
2282                 -- a dead case_bndr' will still advertise its deadness
2283                 -- This is really important because in
2284                 --      case e of b { (# p,q #) -> ... }
2285                 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
2286                 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
2287                 -- In the new alts we build, we have the new case binder, so it must retain
2288                 -- its deadness.
2289         -- NB: we don't use alt_env further; it has the substEnv for
2290         --     the alternatives, and we don't want that
2291
2292         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
2293         ; return (env'',  -- Note [Duplicated env]
2294                   Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
2295                   nodup_cont) }
2296
2297
2298 mkDupableAlts :: SimplEnv -> OutId -> [InAlt]
2299               -> SimplM (SimplEnv, [InAlt])
2300 -- Absorbs the continuation into the new alternatives
2301
2302 mkDupableAlts env case_bndr' the_alts
2303   = go env the_alts
2304   where
2305     go env0 [] = return (env0, [])
2306     go env0 (alt:alts)
2307         = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt
2308              ; (env2, alts') <- go env1 alts
2309              ; return (env2, alt' : alts' ) }
2310
2311 mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
2312               -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
2313 mkDupableAlt env case_bndr (con, bndrs', rhs')
2314   | exprIsDupable rhs'  -- Note [Small alternative rhs]
2315   = return (env, (con, bndrs', rhs'))
2316   | otherwise
2317   = do  { let rhs_ty'  = exprType rhs'
2318               scrut_ty = idType case_bndr
2319               case_bndr_w_unf   
2320                 = case con of 
2321                       DEFAULT    -> case_bndr                                   
2322                       DataAlt dc -> setIdUnfolding case_bndr unf
2323                           where
2324                                  -- See Note [Case binders and join points]
2325                              unf = mkInlineUnfolding Nothing rhs
2326                              rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
2327                                                 ++ varsToCoreExprs bndrs')
2328
2329                       LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
2330                                                 <+> ppr case_bndr <+> ppr con )
2331                                    case_bndr
2332                            -- The case binder is alive but trivial, so why has 
2333                            -- it not been substituted away?
2334
2335               used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
2336                           | otherwise              = bndrs' ++ [case_bndr_w_unf]
2337               
2338               abstract_over bndr
2339                   | isTyVar bndr = True -- Abstract over all type variables just in case
2340                   | otherwise    = not (isDeadBinder bndr)
2341                         -- The deadness info on the new Ids is preserved by simplBinders
2342
2343         ; (final_bndrs', final_args)    -- Note [Join point abstraction]
2344                 <- if (any isId used_bndrs')
2345                    then return (used_bndrs', varsToCoreExprs used_bndrs')
2346                     else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
2347                             ; return ([rw_id], [Var realWorldPrimId]) }
2348
2349         ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
2350                 -- Note [Funky mkPiTypes]
2351
2352         ; let   -- We make the lambdas into one-shot-lambdas.  The
2353                 -- join point is sure to be applied at most once, and doing so
2354                 -- prevents the body of the join point being floated out by
2355                 -- the full laziness pass
2356                 really_final_bndrs     = map one_shot final_bndrs'
2357                 one_shot v | isId v    = setOneShotLambda v
2358                            | otherwise = v
2359                 join_rhs   = mkLams really_final_bndrs rhs'
2360                 join_arity = exprArity join_rhs
2361                 join_call  = mkApps (Var join_bndr) final_args
2362
2363         ; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs)
2364         ; return (env', (con, bndrs', join_call)) }
2365                 -- See Note [Duplicated env]
2366 \end{code}
2367
2368 Note [Fusing case continuations]
2369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2370 It's important to fuse two successive case continuations when the
2371 first has one alternative.  That's why we call prepareCaseCont here.
2372 Consider this, which arises from thunk splitting (see Note [Thunk
2373 splitting] in WorkWrap):
2374
2375       let
2376         x* = case (case v of {pn -> rn}) of 
2377                I# a -> I# a
2378       in body
2379
2380 The simplifier will find
2381     (Var v) with continuation  
2382             Select (pn -> rn) (
2383             Select [I# a -> I# a] (
2384             StrictBind body Stop
2385
2386 So we'll call mkDupableCont on 
2387    Select [I# a -> I# a] (StrictBind body Stop)
2388 There is just one alternative in the first Select, so we want to
2389 simplify the rhs (I# a) with continuation (StricgtBind body Stop)
2390 Supposing that body is big, we end up with
2391           let $j a = <let x = I# a in body> 
2392           in case v of { pn -> case rn of 
2393                                  I# a -> $j a }
2394 This is just what we want because the rn produces a box that
2395 the case rn cancels with.  
2396
2397 See Trac #4957 a fuller example.
2398
2399 Note [Case binders and join points]
2400 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2401 Consider this 
2402    case (case .. ) of c {
2403      I# c# -> ....c....
2404
2405 If we make a join point with c but not c# we get
2406   $j = \c -> ....c....
2407
2408 But if later inlining scrutines the c, thus
2409
2410   $j = \c -> ... case c of { I# y -> ... } ...
2411
2412 we won't see that 'c' has already been scrutinised.  This actually
2413 happens in the 'tabulate' function in wave4main, and makes a significant
2414 difference to allocation.
2415
2416 An alternative plan is this:
2417
2418    $j = \c# -> let c = I# c# in ...c....
2419
2420 but that is bad if 'c' is *not* later scrutinised.  
2421
2422 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
2423 (an InlineRule) that it's really I# c#, thus
2424    
2425    $j = \c# -> \c[=I# c#] -> ...c....
2426
2427 Absence analysis may later discard 'c'.
2428
2429 NB: take great care when doing strictness analysis; 
2430     see Note [Lamba-bound unfoldings] in DmdAnal.
2431
2432 Also note that we can still end up passing stuff that isn't used.  Before
2433 strictness analysis we have
2434    let $j x y c{=(x,y)} = (h c, ...)
2435    in ...
2436 After strictness analysis we see that h is strict, we end up with
2437    let $j x y c{=(x,y)} = ($wh x y, ...)
2438 and c is unused.
2439    
2440 Note [Duplicated env]
2441 ~~~~~~~~~~~~~~~~~~~~~
2442 Some of the alternatives are simplified, but have not been turned into a join point
2443 So they *must* have an zapped subst-env.  So we can't use completeNonRecX to
2444 bind the join point, because it might to do PostInlineUnconditionally, and
2445 we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
2446 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
2447 at worst delays the join-point inlining.
2448
2449 Note [Small alternative rhs]
2450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2451 It is worth checking for a small RHS because otherwise we
2452 get extra let bindings that may cause an extra iteration of the simplifier to
2453 inline back in place.  Quite often the rhs is just a variable or constructor.
2454 The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
2455 iterations because the version with the let bindings looked big, and so wasn't
2456 inlined, but after the join points had been inlined it looked smaller, and so
2457 was inlined.
2458
2459 NB: we have to check the size of rhs', not rhs.
2460 Duplicating a small InAlt might invalidate occurrence information
2461 However, if it *is* dupable, we return the *un* simplified alternative,
2462 because otherwise we'd need to pair it up with an empty subst-env....
2463 but we only have one env shared between all the alts.
2464 (Remember we must zap the subst-env before re-simplifying something).
2465 Rather than do this we simply agree to re-simplify the original (small) thing later.
2466
2467 Note [Funky mkPiTypes]
2468 ~~~~~~~~~~~~~~~~~~~~~~
2469 Notice the funky mkPiTypes.  If the contructor has existentials
2470 it's possible that the join point will be abstracted over
2471 type varaibles as well as term variables.
2472  Example:  Suppose we have
2473         data T = forall t.  C [t]
2474  Then faced with
2475         case (case e of ...) of
2476             C t xs::[t] -> rhs
2477  We get the join point
2478         let j :: forall t. [t] -> ...
2479             j = /\t \xs::[t] -> rhs
2480         in
2481         case (case e of ...) of
2482             C t xs::[t] -> j t xs
2483
2484 Note [Join point abstaction]
2485 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2486 If we try to lift a primitive-typed something out
2487 for let-binding-purposes, we will *caseify* it (!),
2488 with potentially-disastrous strictness results.  So
2489 instead we turn it into a function: \v -> e
2490 where v::State# RealWorld#.  The value passed to this function
2491 is realworld#, which generates (almost) no code.
2492
2493 There's a slight infelicity here: we pass the overall
2494 case_bndr to all the join points if it's used in *any* RHS,
2495 because we don't know its usage in each RHS separately
2496
2497 We used to say "&& isUnLiftedType rhs_ty'" here, but now
2498 we make the join point into a function whenever used_bndrs'
2499 is empty.  This makes the join-point more CPR friendly.
2500 Consider:       let j = if .. then I# 3 else I# 4
2501                 in case .. of { A -> j; B -> j; C -> ... }
2502
2503 Now CPR doesn't w/w j because it's a thunk, so
2504 that means that the enclosing function can't w/w either,
2505 which is a lose.  Here's the example that happened in practice:
2506         kgmod :: Int -> Int -> Int
2507         kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
2508                     then 78
2509                     else 5
2510
2511 I have seen a case alternative like this:
2512         True -> \v -> ...
2513 It's a bit silly to add the realWorld dummy arg in this case, making
2514         $j = \s v -> ...
2515            True -> $j s
2516 (the \v alone is enough to make CPR happy) but I think it's rare
2517
2518 Note [Duplicating StrictArg]
2519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2520 The original plan had (where E is a big argument)
2521 e.g.    f E [..hole..]
2522         ==>     let $j = \a -> f E a
2523                 in $j [..hole..]
2524
2525 But this is terrible! Here's an example:
2526         && E (case x of { T -> F; F -> T })
2527 Now, && is strict so we end up simplifying the case with
2528 an ArgOf continuation.  If we let-bind it, we get
2529         let $j = \v -> && E v
2530         in simplExpr (case x of { T -> F; F -> T })
2531                      (ArgOf (\r -> $j r)
2532 And after simplifying more we get
2533         let $j = \v -> && E v
2534         in case x of { T -> $j F; F -> $j T }
2535 Which is a Very Bad Thing
2536
2537 What we do now is this
2538         f E [..hole..]
2539         ==>     let a = E
2540                 in f a [..hole..]
2541 Now if the thing in the hole is a case expression (which is when
2542 we'll call mkDupableCont), we'll push the function call into the
2543 branches, which is what we want.  Now RULES for f may fire, and
2544 call-pattern specialisation.  Here's an example from Trac #3116
2545      go (n+1) (case l of
2546                  1  -> bs'
2547                  _  -> Chunk p fpc (o+1) (l-1) bs')
2548 If we can push the call for 'go' inside the case, we get
2549 call-pattern specialisation for 'go', which is *crucial* for 
2550 this program.
2551
2552 Here is the (&&) example: 
2553         && E (case x of { T -> F; F -> T })
2554   ==>   let a = E in 
2555         case x of { T -> && a F; F -> && a T }
2556 Much better!
2557
2558 Notice that 
2559   * Arguments to f *after* the strict one are handled by 
2560     the ApplyTo case of mkDupableCont.  Eg
2561         f [..hole..] E
2562
2563   * We can only do the let-binding of E because the function
2564     part of a StrictArg continuation is an explicit syntax
2565     tree.  In earlier versions we represented it as a function
2566     (CoreExpr -> CoreEpxr) which we couldn't take apart.
2567
2568 Do *not* duplicate StrictBind and StritArg continuations.  We gain
2569 nothing by propagating them into the expressions, and we do lose a
2570 lot.  
2571
2572 The desire not to duplicate is the entire reason that
2573 mkDupableCont returns a pair of continuations.
2574
2575 Note [Duplicating StrictBind]
2576 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2577 Unlike StrictArg, there doesn't seem anything to gain from
2578 duplicating a StrictBind continuation, so we don't.
2579
2580
2581 Note [Single-alternative cases]
2582 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2583 This case is just like the ArgOf case.  Here's an example:
2584         data T a = MkT !a
2585         ...(MkT (abs x))...
2586 Then we get
2587         case (case x of I# x' ->
2588               case x' <# 0# of
2589                 True  -> I# (negate# x')
2590                 False -> I# x') of y {
2591           DEFAULT -> MkT y
2592 Because the (case x) has only one alternative, we'll transform to
2593         case x of I# x' ->
2594         case (case x' <# 0# of
2595                 True  -> I# (negate# x')
2596                 False -> I# x') of y {
2597           DEFAULT -> MkT y
2598 But now we do *NOT* want to make a join point etc, giving
2599         case x of I# x' ->
2600         let $j = \y -> MkT y
2601         in case x' <# 0# of
2602                 True  -> $j (I# (negate# x'))
2603                 False -> $j (I# x')
2604 In this case the $j will inline again, but suppose there was a big
2605 strict computation enclosing the orginal call to MkT.  Then, it won't
2606 "see" the MkT any more, because it's big and won't get duplicated.
2607 And, what is worse, nothing was gained by the case-of-case transform.
2608
2609 So, in circumstances like these, we don't want to build join points
2610 and push the outer case into the branches of the inner one. Instead,
2611 don't duplicate the continuation. 
2612
2613 When should we use this strategy?  We should not use it on *every*
2614 single-alternative case:
2615   e.g.  case (case ....) of (a,b) -> (# a,b #)
2616 Here we must push the outer case into the inner one!
2617 Other choices:
2618
2619    * Match [(DEFAULT,_,_)], but in the common case of Int,
2620      the alternative-filling-in code turned the outer case into
2621                 case (...) of y { I# _ -> MkT y }
2622
2623    * Match on single alternative plus (not (isDeadBinder case_bndr))
2624      Rationale: pushing the case inwards won't eliminate the construction.
2625      But there's a risk of
2626                 case (...) of y { (a,b) -> let z=(a,b) in ... }
2627      Now y looks dead, but it'll come alive again.  Still, this
2628      seems like the best option at the moment.
2629
2630    * Match on single alternative plus (all (isDeadBinder bndrs))
2631      Rationale: this is essentially  seq.
2632
2633    * Match when the rhs is *not* duplicable, and hence would lead to a
2634      join point.  This catches the disaster-case above.  We can test
2635      the *un-simplified* rhs, which is fine.  It might get bigger or
2636      smaller after simplification; if it gets smaller, this case might
2637      fire next time round.  NB also that we must test contIsDupable
2638      case_cont *too, because case_cont might be big!
2639
2640      HOWEVER: I found that this version doesn't work well, because
2641      we can get         let x = case (...) of { small } in ...case x...
2642      When x is inlined into its full context, we find that it was a bad
2643      idea to have pushed the outer case inside the (...) case.
2644
2645 Note [Single-alternative-unlifted]
2646 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2647 Here's another single-alternative where we really want to do case-of-case:
2648
2649 data Mk1 = Mk1 Int# | Mk2 Int#
2650
2651 M1.f =
2652     \r [x_s74 y_s6X]
2653         case
2654             case y_s6X of tpl_s7m {
2655               M1.Mk1 ipv_s70 -> ipv_s70;
2656               M1.Mk2 ipv_s72 -> ipv_s72;
2657             }
2658         of
2659         wild_s7c
2660         { __DEFAULT ->
2661               case
2662                   case x_s74 of tpl_s7n {
2663                     M1.Mk1 ipv_s77 -> ipv_s77;
2664                     M1.Mk2 ipv_s79 -> ipv_s79;
2665                   }
2666               of
2667               wild1_s7b
2668               { __DEFAULT -> ==# [wild1_s7b wild_s7c];
2669               };
2670         };
2671
2672 So the outer case is doing *nothing at all*, other than serving as a
2673 join-point.  In this case we really want to do case-of-case and decide
2674 whether to use a real join point or just duplicate the continuation:
2675
2676     let $j s7c = case x of
2677                    Mk1 ipv77 -> (==) s7c ipv77
2678                    Mk1 ipv79 -> (==) s7c ipv79
2679     in
2680     case y of 
2681       Mk1 ipv70 -> $j ipv70
2682       Mk2 ipv72 -> $j ipv72
2683
2684 Hence: check whether the case binder's type is unlifted, because then
2685 the outer case is *not* a seq.