Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules
[ghc.git] / compiler / simplCore / SimplUtils.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SimplUtils]{The simplifier utilities}
5
6 \begin{code}
7 {-# OPTIONS_GHC -w #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
12 -- for details
13
14 module SimplUtils (
15         -- Rebuilding
16         mkLam, mkCase, prepareAlts, bindCaseBndr,
17
18         -- Inlining,
19         preInlineUnconditionally, postInlineUnconditionally, 
20         activeInline, activeRule, inlineMode,
21
22         -- The continuation type
23         SimplCont(..), DupFlag(..), LetRhsFlag(..), 
24         contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
25         countValArgs, countArgs, splitInlineCont,
26         mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
27         interestingCallContext, interestingArgContext,
28
29         interestingArg, mkArgInfo,
30         
31         abstractFloats
32     ) where
33
34 #include "HsVersions.h"
35
36 import SimplEnv
37 import DynFlags
38 import StaticFlags
39 import CoreSyn
40 import qualified CoreSubst
41 import PprCore
42 import CoreFVs
43 import CoreUtils
44 import Literal  
45 import CoreUnfold
46 import MkId
47 import Name
48 import Id
49 import Var      ( isCoVar )
50 import NewDemand
51 import SimplMonad
52 import Type     ( Type, funArgTy, mkForAllTys, mkTyVarTys, 
53                   splitTyConApp_maybe, tyConAppArgs )
54 import TyCon
55 import DataCon
56 import Unify    ( dataConCannotMatch )
57 import VarSet
58 import BasicTypes
59 import Util
60 import Outputable
61 import List( nub )
62 \end{code}
63
64
65 %************************************************************************
66 %*                                                                      *
67                 The SimplCont type
68 %*                                                                      *
69 %************************************************************************
70
71 A SimplCont allows the simplifier to traverse the expression in a 
72 zipper-like fashion.  The SimplCont represents the rest of the expression,
73 "above" the point of interest.
74
75 You can also think of a SimplCont as an "evaluation context", using
76 that term in the way it is used for operational semantics. This is the
77 way I usually think of it, For example you'll often see a syntax for
78 evaluation context looking like
79         C ::= []  |  C e   |  case C of alts  |  C `cast` co
80 That's the kind of thing we are doing here, and I use that syntax in
81 the comments.
82
83
84 Key points:
85   * A SimplCont describes a *strict* context (just like 
86     evaluation contexts do).  E.g. Just [] is not a SimplCont
87
88   * A SimplCont describes a context that *does not* bind
89     any variables.  E.g. \x. [] is not a SimplCont
90
91 \begin{code}
92 data SimplCont  
93   = Stop                -- An empty context, or hole, []     
94         OutType         -- Type of the result
95         LetRhsFlag
96         Bool            -- True <=> There is something interesting about
97                         --          the context, and hence the inliner
98                         --          should be a bit keener (see interestingCallContext)
99                         -- Two cases:
100                         -- (a) This is the RHS of a thunk whose type suggests
101                         --     that update-in-place would be possible
102                         -- (b) This is an argument of a function that has RULES
103                         --     Inlining the call might allow the rule to fire
104
105   | CoerceIt            -- C `cast` co
106         OutCoercion             -- The coercion simplified
107         SimplCont
108
109   | ApplyTo             -- C arg
110         DupFlag 
111         InExpr SimplEnv         -- The argument and its static env
112         SimplCont
113
114   | Select              -- case C of alts
115         DupFlag 
116         InId [InAlt] SimplEnv   -- The case binder, alts, and subst-env
117         SimplCont
118
119   -- The two strict forms have no DupFlag, because we never duplicate them
120   | StrictBind          -- (\x* \xs. e) C
121         InId [InBndr]           -- let x* = [] in e     
122         InExpr SimplEnv         --      is a special case 
123         SimplCont       
124
125   | StrictArg           -- e C
126         OutExpr OutType         -- e and its type
127         (Bool,[Bool])           -- Whether the function at the head of e has rules,
128         SimplCont               --     plus strictness flags for further args
129
130 data LetRhsFlag = AnArg         -- It's just an argument not a let RHS
131                 | AnRhs         -- It's the RHS of a let (so please float lets out of big lambdas)
132
133 instance Outputable LetRhsFlag where
134   ppr AnArg = ptext SLIT("arg")
135   ppr AnRhs = ptext SLIT("rhs")
136
137 instance Outputable SimplCont where
138   ppr (Stop ty is_rhs _)             = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
139   ppr (ApplyTo dup arg se cont)      = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg)
140                                           {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
141   ppr (StrictBind b _ _ _ cont)      = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
142   ppr (StrictArg f _ _ cont)         = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
143   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ 
144                                        (nest 4 (ppr alts)) $$ ppr cont 
145   ppr (CoerceIt co cont)             = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
146
147 data DupFlag = OkToDup | NoDup
148
149 instance Outputable DupFlag where
150   ppr OkToDup = ptext SLIT("ok")
151   ppr NoDup   = ptext SLIT("nodup")
152
153
154
155 -------------------
156 mkBoringStop :: OutType -> SimplCont
157 mkBoringStop ty = Stop ty AnArg False
158
159 mkLazyArgStop :: OutType -> Bool -> SimplCont
160 mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
161
162 mkRhsStop :: OutType -> SimplCont
163 mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
164
165 -------------------
166 contIsRhsOrArg (Stop {})         = True
167 contIsRhsOrArg (StrictBind {})   = True
168 contIsRhsOrArg (StrictArg {})    = True
169 contIsRhsOrArg other             = False
170
171 -------------------
172 contIsDupable :: SimplCont -> Bool
173 contIsDupable (Stop {})                  = True
174 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
175 contIsDupable (Select   OkToDup _ _ _ _) = True
176 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
177 contIsDupable other                      = False
178
179 -------------------
180 contIsTrivial :: SimplCont -> Bool
181 contIsTrivial (Stop {})                   = True
182 contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
183 contIsTrivial (CoerceIt _ cont)           = contIsTrivial cont
184 contIsTrivial other                       = False
185
186 -------------------
187 contResultType :: SimplCont -> OutType
188 contResultType (Stop to_ty _ _)          = to_ty
189 contResultType (StrictArg _ _ _ cont)    = contResultType cont
190 contResultType (StrictBind _ _ _ _ cont) = contResultType cont
191 contResultType (ApplyTo _ _ _ cont)      = contResultType cont
192 contResultType (CoerceIt _ cont)         = contResultType cont
193 contResultType (Select _ _ _ _ cont)     = contResultType cont
194
195 -------------------
196 countValArgs :: SimplCont -> Int
197 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
198 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
199 countValArgs other                         = 0
200
201 countArgs :: SimplCont -> Int
202 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
203 countArgs other                   = 0
204
205 contArgs :: SimplCont -> ([OutExpr], SimplCont)
206 -- Uses substitution to turn each arg into an OutExpr
207 contArgs cont = go [] cont
208   where
209     go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
210     go args cont                    = (reverse args, cont)
211
212 dropArgs :: Int -> SimplCont -> SimplCont
213 dropArgs 0 cont = cont
214 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
215 dropArgs n other                = pprPanic "dropArgs" (ppr n <+> ppr other)
216
217 --------------------
218 splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
219 -- Returns Nothing if the continuation should dissolve an InlineMe Note
220 -- Return Just (c1,c2) otherwise, 
221 --      where c1 is the continuation to put inside the InlineMe 
222 --      and   c2 outside
223
224 -- Example: (__inline_me__ (/\a. e)) ty
225 --      Here we want to do the beta-redex without dissolving the InlineMe
226 -- See test simpl017 (and Trac #1627) for a good example of why this is important
227
228 splitInlineCont (ApplyTo dup (Type ty) se c)
229   | Just (c1, c2) <- splitInlineCont c          = Just (ApplyTo dup (Type ty) se c1, c2)
230 splitInlineCont cont@(Stop ty _ _)              = Just (mkBoringStop ty, cont)
231 splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont)
232 splitInlineCont cont@(StrictArg _ fun_ty _ _)   = Just (mkBoringStop (funArgTy fun_ty), cont)
233 splitInlineCont other                           = Nothing
234         -- NB: the calculation of the type for mkBoringStop is an annoying
235         --     duplication of the same calucation in mkDupableCont
236 \end{code}
237
238
239 \begin{code}
240 interestingArg :: OutExpr -> Bool
241         -- An argument is interesting if it has *some* structure
242         -- We are here trying to avoid unfolding a function that
243         -- is applied only to variables that have no unfolding
244         -- (i.e. they are probably lambda bound): f x y z
245         -- There is little point in inlining f here.
246 interestingArg (Var v)           = hasSomeUnfolding (idUnfolding v)
247                                         -- Was: isValueUnfolding (idUnfolding v')
248                                         -- But that seems over-pessimistic
249                                  || isDataConWorkId v
250                                         -- This accounts for an argument like
251                                         -- () or [], which is definitely interesting
252 interestingArg (Type _)          = False
253 interestingArg (App fn (Type _)) = interestingArg fn
254 interestingArg (Note _ a)        = interestingArg a
255
256 -- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
257 -- interestingArg expr | isUnLiftedType (exprType expr)
258 --        -- Unlifted args are only ever interesting if we know what they are
259 --  =                  case expr of
260 --                        Lit lit -> True
261 --                        _       -> False
262
263 interestingArg other             = True
264         -- Consider     let x = 3 in f x
265         -- The substitution will contain (x -> ContEx 3), and we want to
266         -- to say that x is an interesting argument.
267         -- But consider also (\x. f x y) y
268         -- The substitution will contain (x -> ContEx y), and we want to say
269         -- that x is not interesting (assuming y has no unfolding)
270 \end{code}
271
272
273 Comment about interestingCallContext
274 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
275 We want to avoid inlining an expression where there can't possibly be
276 any gain, such as in an argument position.  Hence, if the continuation
277 is interesting (eg. a case scrutinee, application etc.) then we
278 inline, otherwise we don't.  
279
280 Previously some_benefit used to return True only if the variable was
281 applied to some value arguments.  This didn't work:
282
283         let x = _coerce_ (T Int) Int (I# 3) in
284         case _coerce_ Int (T Int) x of
285                 I# y -> ....
286
287 we want to inline x, but can't see that it's a constructor in a case
288 scrutinee position, and some_benefit is False.
289
290 Another example:
291
292 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
293
294 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
295
296 we'd really like to inline dMonadST here, but we *don't* want to
297 inline if the case expression is just
298
299         case x of y { DEFAULT -> ... }
300
301 since we can just eliminate this case instead (x is in WHNF).  Similar
302 applies when x is bound to a lambda expression.  Hence
303 contIsInteresting looks for case expressions with just a single
304 default case.
305
306 \begin{code}
307 interestingCallContext :: Bool          -- False <=> no args at all
308                        -> Bool          -- False <=> no value args
309                        -> SimplCont -> Bool
310         -- The "lone-variable" case is important.  I spent ages
311         -- messing about with unsatisfactory varaints, but this is nice.
312         -- The idea is that if a variable appear all alone
313         --      as an arg of lazy fn, or rhs    Stop
314         --      as scrutinee of a case          Select
315         --      as arg of a strict fn           ArgOf
316         -- then we should not inline it (unless there is some other reason,
317         -- e.g. is is the sole occurrence).  We achieve this by making
318         -- interestingCallContext return False for a lone variable.
319         --
320         -- Why?  At least in the case-scrutinee situation, turning
321         --      let x = (a,b) in case x of y -> ...
322         -- into
323         --      let x = (a,b) in case (a,b) of y -> ...
324         -- and thence to 
325         --      let x = (a,b) in let y = (a,b) in ...
326         -- is bad if the binding for x will remain.
327         --
328         -- Another example: I discovered that strings
329         -- were getting inlined straight back into applications of 'error'
330         -- because the latter is strict.
331         --      s = "foo"
332         --      f = \x -> ...(error s)...
333
334         -- Fundamentally such contexts should not ecourage inlining because
335         -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
336         -- so there's no gain.
337         --
338         -- However, even a type application or coercion isn't a lone variable.
339         -- Consider
340         --      case $fMonadST @ RealWorld of { :DMonad a b c -> c }
341         -- We had better inline that sucker!  The case won't see through it.
342         --
343         -- For now, I'm treating treating a variable applied to types 
344         -- in a *lazy* context "lone". The motivating example was
345         --      f = /\a. \x. BIG
346         --      g = /\a. \y.  h (f a)
347         -- There's no advantage in inlining f here, and perhaps
348         -- a significant disadvantage.  Hence some_val_args in the Stop case
349
350 interestingCallContext some_args some_val_args cont
351   = interesting cont
352   where
353     interesting (Select {})              = some_args
354     interesting (ApplyTo {})             = True -- Can happen if we have (coerce t (f x)) y
355                                                 -- Perhaps True is a bit over-keen, but I've
356                                                 -- seen (coerce f) x, where f has an INLINE prag,
357                                                 -- So we have to give some motivaiton for inlining it
358     interesting (StrictArg {})           = some_val_args
359     interesting (StrictBind {})          = some_val_args        -- ??
360     interesting (Stop ty _ interesting)  = some_val_args && interesting
361     interesting (CoerceIt _ cont)        = interesting cont
362         -- If this call is the arg of a strict function, the context
363         -- is a bit interesting.  If we inline here, we may get useful
364         -- evaluation information to avoid repeated evals: e.g.
365         --      x + (y * z)
366         -- Here the contIsInteresting makes the '*' keener to inline,
367         -- which in turn exposes a constructor which makes the '+' inline.
368         -- Assuming that +,* aren't small enough to inline regardless.
369         --
370         -- It's also very important to inline in a strict context for things
371         -- like
372         --              foldr k z (f x)
373         -- Here, the context of (f x) is strict, and if f's unfolding is
374         -- a build it's *great* to inline it here.  So we must ensure that
375         -- the context for (f x) is not totally uninteresting.
376
377
378 -------------------
379 mkArgInfo :: Id
380           -> Int        -- Number of value args
381           -> SimplCont  -- Context of the cal
382           -> (Bool, [Bool])     -- Arg info
383 -- The arg info consists of
384 --  * A Bool indicating if the function has rules (recursively)
385 --  * A [Bool] indicating strictness for each arg
386 -- The [Bool] is usually infinite, but if it is finite it 
387 -- guarantees that the function diverges after being given
388 -- that number of args
389
390 mkArgInfo fun n_val_args call_cont
391   = (interestingArgContext fun call_cont, fun_stricts)
392   where
393     vanilla_stricts, fun_stricts :: [Bool]
394     vanilla_stricts  = repeat False
395
396     fun_stricts
397       = case splitStrictSig (idNewStrictness fun) of
398           (demands, result_info)
399                 | not (demands `lengthExceeds` n_val_args)
400                 ->      -- Enough args, use the strictness given.
401                         -- For bottoming functions we used to pretend that the arg
402                         -- is lazy, so that we don't treat the arg as an
403                         -- interesting context.  This avoids substituting
404                         -- top-level bindings for (say) strings into 
405                         -- calls to error.  But now we are more careful about
406                         -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
407                    if isBotRes result_info then
408                         map isStrictDmd demands         -- Finite => result is bottom
409                    else
410                         map isStrictDmd demands ++ vanilla_stricts
411
412           other -> vanilla_stricts      -- Not enough args, or no strictness
413
414 interestingArgContext :: Id -> SimplCont -> Bool
415 -- If the argument has form (f x y), where x,y are boring,
416 -- and f is marked INLINE, then we don't want to inline f.
417 -- But if the context of the argument is
418 --      g (f x y) 
419 -- where g has rules, then we *do* want to inline f, in case it
420 -- exposes a rule that might fire.  Similarly, if the context is
421 --      h (g (f x x))
422 -- where h has rules, then we do want to inline f.
423 -- The interesting_arg_ctxt flag makes this happen; if it's
424 -- set, the inliner gets just enough keener to inline f 
425 -- regardless of how boring f's arguments are, if it's marked INLINE
426 --
427 -- The alternative would be to *always* inline an INLINE function,
428 -- regardless of how boring its context is; but that seems overkill
429 -- For example, it'd mean that wrapper functions were always inlined
430 interestingArgContext fn cont
431   = idHasRules fn || go cont
432   where
433     go (Select {})            = False
434     go (ApplyTo {})           = False
435     go (StrictArg {})         = True
436     go (StrictBind {})        = False   -- ??
437     go (CoerceIt _ c)         = go c
438     go (Stop _ _ interesting) = interesting
439
440 -------------------
441 canUpdateInPlace :: Type -> Bool
442 -- Consider   let x = <wurble> in ...
443 -- If <wurble> returns an explicit constructor, we might be able
444 -- to do update in place.  So we treat even a thunk RHS context
445 -- as interesting if update in place is possible.  We approximate
446 -- this by seeing if the type has a single constructor with a
447 -- small arity.  But arity zero isn't good -- we share the single copy
448 -- for that case, so no point in sharing.
449
450 canUpdateInPlace ty 
451   | not opt_UF_UpdateInPlace = False
452   | otherwise
453   = case splitTyConApp_maybe ty of 
454         Nothing         -> False 
455         Just (tycon, _) -> case tyConDataCons_maybe tycon of
456                                 Just [dc]  -> arity == 1 || arity == 2
457                                            where
458                                               arity = dataConRepArity dc
459                                 other -> False
460 \end{code}
461
462
463
464 %************************************************************************
465 %*                                                                      *
466 \subsection{Decisions about inlining}
467 %*                                                                      *
468 %************************************************************************
469
470 Inlining is controlled partly by the SimplifierMode switch.  This has two
471 settings:
472
473         SimplGently     (a) Simplifying before specialiser/full laziness
474                         (b) Simplifiying inside INLINE pragma
475                         (c) Simplifying the LHS of a rule
476                         (d) Simplifying a GHCi expression or Template 
477                                 Haskell splice
478
479         SimplPhase n    Used at all other times
480
481 The key thing about SimplGently is that it does no call-site inlining.
482 Before full laziness we must be careful not to inline wrappers,
483 because doing so inhibits floating
484     e.g. ...(case f x of ...)...
485     ==> ...(case (case x of I# x# -> fw x#) of ...)...
486     ==> ...(case x of I# x# -> case fw x# of ...)...
487 and now the redex (f x) isn't floatable any more.
488
489 The no-inlining thing is also important for Template Haskell.  You might be 
490 compiling in one-shot mode with -O2; but when TH compiles a splice before
491 running it, we don't want to use -O2.  Indeed, we don't want to inline
492 anything, because the byte-code interpreter might get confused about 
493 unboxed tuples and suchlike.
494
495 INLINE pragmas
496 ~~~~~~~~~~~~~~
497 SimplGently is also used as the mode to simplify inside an InlineMe note.
498
499 \begin{code}
500 inlineMode :: SimplifierMode
501 inlineMode = SimplGently
502 \end{code}
503
504 It really is important to switch off inlinings inside such
505 expressions.  Consider the following example 
506
507         let f = \pq -> BIG
508         in
509         let g = \y -> f y y
510             {-# INLINE g #-}
511         in ...g...g...g...g...g...
512
513 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
514 and thence copied multiple times when g is inlined.
515
516
517 This function may be inlinined in other modules, so we
518 don't want to remove (by inlining) calls to functions that have
519 specialisations, or that may have transformation rules in an importing
520 scope.
521
522 E.g.    {-# INLINE f #-}
523                 f x = ...g...
524
525 and suppose that g is strict *and* has specialisations.  If we inline
526 g's wrapper, we deny f the chance of getting the specialised version
527 of g when f is inlined at some call site (perhaps in some other
528 module).
529
530 It's also important not to inline a worker back into a wrapper.
531 A wrapper looks like
532         wraper = inline_me (\x -> ...worker... )
533 Normally, the inline_me prevents the worker getting inlined into
534 the wrapper (initially, the worker's only call site!).  But,
535 if the wrapper is sure to be called, the strictness analyser will
536 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
537 continuation.  That's why the keep_inline predicate returns True for
538 ArgOf continuations.  It shouldn't do any harm not to dissolve the
539 inline-me note under these circumstances.
540
541 Note that the result is that we do very little simplification
542 inside an InlineMe.  
543
544         all xs = foldr (&&) True xs
545         any p = all . map p  {-# INLINE any #-}
546
547 Problem: any won't get deforested, and so if it's exported and the
548 importer doesn't use the inlining, (eg passes it as an arg) then we
549 won't get deforestation at all.  We havn't solved this problem yet!
550
551
552 preInlineUnconditionally
553 ~~~~~~~~~~~~~~~~~~~~~~~~
554 @preInlineUnconditionally@ examines a bndr to see if it is used just
555 once in a completely safe way, so that it is safe to discard the
556 binding inline its RHS at the (unique) usage site, REGARDLESS of how
557 big the RHS might be.  If this is the case we don't simplify the RHS
558 first, but just inline it un-simplified.
559
560 This is much better than first simplifying a perhaps-huge RHS and then
561 inlining and re-simplifying it.  Indeed, it can be at least quadratically
562 better.  Consider
563
564         x1 = e1
565         x2 = e2[x1]
566         x3 = e3[x2]
567         ...etc...
568         xN = eN[xN-1]
569
570 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
571 This can happen with cascades of functions too:
572
573         f1 = \x1.e1
574         f2 = \xs.e2[f1]
575         f3 = \xs.e3[f3]
576         ...etc...
577
578 THE MAIN INVARIANT is this:
579
580         ----  preInlineUnconditionally invariant -----
581    IF preInlineUnconditionally chooses to inline x = <rhs>
582    THEN doing the inlining should not change the occurrence
583         info for the free vars of <rhs>
584         ----------------------------------------------
585
586 For example, it's tempting to look at trivial binding like
587         x = y
588 and inline it unconditionally.  But suppose x is used many times,
589 but this is the unique occurrence of y.  Then inlining x would change
590 y's occurrence info, which breaks the invariant.  It matters: y
591 might have a BIG rhs, which will now be dup'd at every occurrenc of x.
592
593
594 Evne RHSs labelled InlineMe aren't caught here, because there might be
595 no benefit from inlining at the call site.
596
597 [Sept 01] Don't unconditionally inline a top-level thing, because that
598 can simply make a static thing into something built dynamically.  E.g.
599         x = (a,b)
600         main = \s -> h x
601
602 [Remember that we treat \s as a one-shot lambda.]  No point in
603 inlining x unless there is something interesting about the call site.
604
605 But watch out: if you aren't careful, some useful foldr/build fusion
606 can be lost (most notably in spectral/hartel/parstof) because the
607 foldr didn't see the build.  Doing the dynamic allocation isn't a big
608 deal, in fact, but losing the fusion can be.  But the right thing here
609 seems to be to do a callSiteInline based on the fact that there is
610 something interesting about the call site (it's strict).  Hmm.  That
611 seems a bit fragile.
612
613 Conclusion: inline top level things gaily until Phase 0 (the last
614 phase), at which point don't.
615
616 \begin{code}
617 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
618 preInlineUnconditionally env top_lvl bndr rhs
619   | not active             = False
620   | opt_SimplNoPreInlining = False
621   | otherwise = case idOccInfo bndr of
622                   IAmDead                    -> True    -- Happens in ((\x.1) v)
623                   OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
624                   other                      -> False
625   where
626     phase = getMode env
627     active = case phase of
628                    SimplGently  -> isAlwaysActive prag
629                    SimplPhase n -> isActive n prag
630     prag = idInlinePragma bndr
631
632     try_once in_lam int_cxt     -- There's one textual occurrence
633         | not in_lam = isNotTopLevel top_lvl || early_phase
634         | otherwise  = int_cxt && canInlineInLam rhs
635
636 -- Be very careful before inlining inside a lambda, becuase (a) we must not 
637 -- invalidate occurrence information, and (b) we want to avoid pushing a
638 -- single allocation (here) into multiple allocations (inside lambda).  
639 -- Inlining a *function* with a single *saturated* call would be ok, mind you.
640 --      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
641 --      where 
642 --              is_cheap = exprIsCheap rhs
643 --              ok = is_cheap && int_cxt
644
645         --      int_cxt         The context isn't totally boring
646         -- E.g. let f = \ab.BIG in \y. map f xs
647         --      Don't want to substitute for f, because then we allocate
648         --      its closure every time the \y is called
649         -- But: let f = \ab.BIG in \y. map (f y) xs
650         --      Now we do want to substitute for f, even though it's not 
651         --      saturated, because we're going to allocate a closure for 
652         --      (f y) every time round the loop anyhow.
653
654         -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
655         -- so substituting rhs inside a lambda doesn't change the occ info.
656         -- Sadly, not quite the same as exprIsHNF.
657     canInlineInLam (Lit l)              = True
658     canInlineInLam (Lam b e)            = isRuntimeVar b || canInlineInLam e
659     canInlineInLam (Note _ e)           = canInlineInLam e
660     canInlineInLam _                    = False
661
662     early_phase = case phase of
663                         SimplPhase 0 -> False
664                         other        -> True
665 -- If we don't have this early_phase test, consider
666 --      x = length [1,2,3]
667 -- The full laziness pass carefully floats all the cons cells to
668 -- top level, and preInlineUnconditionally floats them all back in.
669 -- Result is (a) static allocation replaced by dynamic allocation
670 --           (b) many simplifier iterations because this tickles
671 --               a related problem; only one inlining per pass
672 -- 
673 -- On the other hand, I have seen cases where top-level fusion is
674 -- lost if we don't inline top level thing (e.g. string constants)
675 -- Hence the test for phase zero (which is the phase for all the final
676 -- simplifications).  Until phase zero we take no special notice of
677 -- top level things, but then we become more leery about inlining
678 -- them.  
679
680 \end{code}
681
682 postInlineUnconditionally
683 ~~~~~~~~~~~~~~~~~~~~~~~~~
684 @postInlineUnconditionally@ decides whether to unconditionally inline
685 a thing based on the form of its RHS; in particular if it has a
686 trivial RHS.  If so, we can inline and discard the binding altogether.
687
688 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
689 only have *forward* references Hence, it's safe to discard the binding
690         
691 NOTE: This isn't our last opportunity to inline.  We're at the binding
692 site right now, and we'll get another opportunity when we get to the
693 ocurrence(s)
694
695 Note that we do this unconditional inlining only for trival RHSs.
696 Don't inline even WHNFs inside lambdas; doing so may simply increase
697 allocation when the function is called. This isn't the last chance; see
698 NOTE above.
699
700 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
701 Because we don't even want to inline them into the RHS of constructor
702 arguments. See NOTE above
703
704 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
705 it's best to inline it anyway.  We often get a=E; b=a from desugaring,
706 with both a and b marked NOINLINE.  But that seems incompatible with
707 our new view that inlining is like a RULE, so I'm sticking to the 'active'
708 story for now.
709
710 \begin{code}
711 postInlineUnconditionally 
712     :: SimplEnv -> TopLevelFlag
713     -> InId             -- The binder (an OutId would be fine too)
714     -> OccInfo          -- From the InId
715     -> OutExpr
716     -> Unfolding
717     -> Bool
718 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
719   | not active             = False
720   | isLoopBreaker occ_info = False      -- If it's a loop-breaker of any kind, dont' inline
721                                         -- because it might be referred to "earlier"
722   | isExportedId bndr      = False
723   | exprIsTrivial rhs      = True
724   | otherwise
725   = case occ_info of
726         -- The point of examining occ_info here is that for *non-values* 
727         -- that occur outside a lambda, the call-site inliner won't have
728         -- a chance (becuase it doesn't know that the thing
729         -- only occurs once).   The pre-inliner won't have gotten
730         -- it either, if the thing occurs in more than one branch
731         -- So the main target is things like
732         --      let x = f y in
733         --      case v of
734         --         True  -> case x of ...
735         --         False -> case x of ...
736         -- I'm not sure how important this is in practice
737       OneOcc in_lam one_br int_cxt      -- OneOcc => no code-duplication issue
738         ->     smallEnoughToInline unfolding    -- Small enough to dup
739                         -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
740                         --
741                         -- NB: Do NOT inline arbitrarily big things, even if one_br is True
742                         -- Reason: doing so risks exponential behaviour.  We simplify a big
743                         --         expression, inline it, and simplify it again.  But if the
744                         --         very same thing happens in the big expression, we get 
745                         --         exponential cost!
746                         -- PRINCIPLE: when we've already simplified an expression once, 
747                         -- make sure that we only inline it if it's reasonably small.
748
749            &&  ((isNotTopLevel top_lvl && not in_lam) || 
750                         -- But outside a lambda, we want to be reasonably aggressive
751                         -- about inlining into multiple branches of case
752                         -- e.g. let x = <non-value> 
753                         --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } 
754                         -- Inlining can be a big win if C3 is the hot-spot, even if
755                         -- the uses in C1, C2 are not 'interesting'
756                         -- An example that gets worse if you add int_cxt here is 'clausify'
757
758                 (isCheapUnfolding unfolding && int_cxt))
759                         -- isCheap => acceptable work duplication; in_lam may be true
760                         -- int_cxt to prevent us inlining inside a lambda without some 
761                         -- good reason.  See the notes on int_cxt in preInlineUnconditionally
762
763       IAmDead -> True   -- This happens; for example, the case_bndr during case of
764                         -- known constructor:  case (a,b) of x { (p,q) -> ... }
765                         -- Here x isn't mentioned in the RHS, so we don't want to
766                         -- create the (dead) let-binding  let x = (a,b) in ...
767
768       other -> False
769
770 -- Here's an example that we don't handle well:
771 --      let f = if b then Left (\x.BIG) else Right (\y.BIG)
772 --      in \y. ....case f of {...} ....
773 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
774 -- But
775 -- * We can't preInlineUnconditionally because that woud invalidate
776 --   the occ info for b.  
777 -- * We can't postInlineUnconditionally because the RHS is big, and
778 --   that risks exponential behaviour
779 -- * We can't call-site inline, because the rhs is big
780 -- Alas!
781
782   where
783     active = case getMode env of
784                    SimplGently  -> isAlwaysActive prag
785                    SimplPhase n -> isActive n prag
786     prag = idInlinePragma bndr
787
788 activeInline :: SimplEnv -> OutId -> Bool
789 activeInline env id
790   = case getMode env of
791       SimplGently -> False
792         -- No inlining at all when doing gentle stuff,
793         -- except for local things that occur once
794         -- The reason is that too little clean-up happens if you 
795         -- don't inline use-once things.   Also a bit of inlining is *good* for
796         -- full laziness; it can expose constant sub-expressions.
797         -- Example in spectral/mandel/Mandel.hs, where the mandelset 
798         -- function gets a useful let-float if you inline windowToViewport
799
800         -- NB: we used to have a second exception, for data con wrappers.
801         -- On the grounds that we use gentle mode for rule LHSs, and 
802         -- they match better when data con wrappers are inlined.
803         -- But that only really applies to the trivial wrappers (like (:)),
804         -- and they are now constructed as Compulsory unfoldings (in MkId)
805         -- so they'll happen anyway.
806
807       SimplPhase n -> isActive n prag
808   where
809     prag = idInlinePragma id
810
811 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
812 -- Nothing => No rules at all
813 activeRule dflags env
814   | not (dopt Opt_RewriteRules dflags)
815   = Nothing     -- Rewriting is off
816   | otherwise
817   = case getMode env of
818         SimplGently  -> Just isAlwaysActive
819                         -- Used to be Nothing (no rules in gentle mode)
820                         -- Main motivation for changing is that I wanted
821                         --      lift String ===> ...
822                         -- to work in Template Haskell when simplifying
823                         -- splices, so we get simpler code for literal strings
824         SimplPhase n -> Just (isActive n)
825 \end{code}
826
827
828 %************************************************************************
829 %*                                                                      *
830         Rebuilding a lambda
831 %*                                                                      *
832 %************************************************************************
833
834 \begin{code}
835 mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
836 -- mkLam tries three things
837 --      a) eta reduction, if that gives a trivial expression
838 --      b) eta expansion [only if there are some value lambdas]
839
840 mkLam [] body 
841   = return body
842 mkLam bndrs body
843   = do  { dflags <- getDOptsSmpl
844         ; mkLam' dflags bndrs body }
845   where
846     mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
847     mkLam' dflags bndrs (Cast body@(Lam _ _) co)
848         -- Note [Casts and lambdas]
849       = do { lam <- mkLam' dflags (bndrs ++ bndrs') body'
850            ; return (mkCoerce (mkPiTypes bndrs co) lam) }
851       where     
852         (bndrs',body') = collectBinders body
853
854     mkLam' dflags bndrs body
855       | dopt Opt_DoEtaReduction dflags,
856         Just etad_lam <- tryEtaReduce bndrs body
857       = do { tick (EtaReduction (head bndrs))
858            ; return etad_lam }
859
860       | dopt Opt_DoLambdaEtaExpansion dflags,
861         any isRuntimeVar bndrs
862       = do { body' <- tryEtaExpansion dflags body
863            ; return (mkLams bndrs body') }
864    
865       | otherwise 
866       = returnSmpl (mkLams bndrs body)
867 \end{code}
868
869 Note [Casts and lambdas]
870 ~~~~~~~~~~~~~~~~~~~~~~~~
871 Consider 
872         (\x. (\y. e) `cast` g1) `cast` g2
873 There is a danger here that the two lambdas look separated, and the 
874 full laziness pass might float an expression to between the two.
875
876 So this equation in mkLam' floats the g1 out, thus:
877         (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)
878 where x:tx.
879
880 In general, this floats casts outside lambdas, where (I hope) they might meet
881 and cancel with some other cast.
882
883
884 --      c) floating lets out through big lambdas 
885 --              [only if all tyvar lambdas, and only if this lambda
886 --               is the RHS of a let]
887
888 {-      Sept 01: I'm experimenting with getting the
889         full laziness pass to float out past big lambdsa
890  | all isTyVar bndrs,   -- Only for big lambdas
891    contIsRhs cont       -- Only try the rhs type-lambda floating
892                         -- if this is indeed a right-hand side; otherwise
893                         -- we end up floating the thing out, only for float-in
894                         -- to float it right back in again!
895  = tryRhsTyLam env bndrs body           `thenSmpl` \ (floats, body') ->
896    returnSmpl (floats, mkLams bndrs body')
897 -}
898
899
900 %************************************************************************
901 %*                                                                      *
902 \subsection{Eta expansion and reduction}
903 %*                                                                      *
904 %************************************************************************
905
906 We try for eta reduction here, but *only* if we get all the 
907 way to an exprIsTrivial expression.    
908 We don't want to remove extra lambdas unless we are going 
909 to avoid allocating this thing altogether
910
911 \begin{code}
912 tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
913 tryEtaReduce bndrs body 
914         -- We don't use CoreUtils.etaReduce, because we can be more
915         -- efficient here:
916         --  (a) we already have the binders
917         --  (b) we can do the triviality test before computing the free vars
918   = go (reverse bndrs) body
919   where
920     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun        -- Loop round
921     go []       fun           | ok_fun fun   = Just fun         -- Success!
922     go _        _                            = Nothing          -- Failure!
923
924     ok_fun fun =  exprIsTrivial fun
925                && not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
926                && (exprIsHNF fun || all ok_lam bndrs)
927     ok_lam v = isTyVar v || isDictId v
928         -- The exprIsHNF is because eta reduction is not 
929         -- valid in general:  \x. bot  /=  bot
930         -- So we need to be sure that the "fun" is a value.
931         --
932         -- However, we always want to reduce (/\a -> f a) to f
933         -- This came up in a RULE: foldr (build (/\a -> g a))
934         --      did not match      foldr (build (/\b -> ...something complex...))
935         -- The type checker can insert these eta-expanded versions,
936         -- with both type and dictionary lambdas; hence the slightly 
937         -- ad-hoc isDictTy
938
939     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
940 \end{code}
941
942
943         Try eta expansion for RHSs
944
945 We go for:
946    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
947                                  (n >= 0)
948
949 where (in both cases) 
950
951         * The xi can include type variables
952
953         * The yi are all value variables
954
955         * N is a NORMAL FORM (i.e. no redexes anywhere)
956           wanting a suitable number of extra args.
957
958 We may have to sandwich some coerces between the lambdas
959 to make the types work.   exprEtaExpandArity looks through coerces
960 when computing arity; and etaExpand adds the coerces as necessary when
961 actually computing the expansion.
962
963 \begin{code}
964 tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
965 -- There is at least one runtime binder in the binders
966 tryEtaExpansion dflags body
967   = getUniquesSmpl                      `thenSmpl` \ us ->
968     returnSmpl (etaExpand fun_arity us body (exprType body))
969   where
970     fun_arity = exprEtaExpandArity dflags body
971 \end{code}
972
973
974 %************************************************************************
975 %*                                                                      *
976 \subsection{Floating lets out of big lambdas}
977 %*                                                                      *
978 %************************************************************************
979
980 Note [Floating and type abstraction]
981 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
982 Consider this:
983         x = /\a. C e1 e2
984 We'd like to float this to 
985         y1 = /\a. e1
986         y2 = /\a. e2
987         x = /\a. C (y1 a) (y2 a)
988 for the usual reasons: we want to inline x rather vigorously.
989
990 You may think that this kind of thing is rare.  But in some programs it is
991 common.  For example, if you do closure conversion you might get:
992
993         data a :-> b = forall e. (e -> a -> b) :$ e
994
995         f_cc :: forall a. a :-> a
996         f_cc = /\a. (\e. id a) :$ ()
997
998 Now we really want to inline that f_cc thing so that the
999 construction of the closure goes away. 
1000
1001 So I have elaborated simplLazyBind to understand right-hand sides that look
1002 like
1003         /\ a1..an. body
1004
1005 and treat them specially. The real work is done in SimplUtils.abstractFloats,
1006 but there is quite a bit of plumbing in simplLazyBind as well.
1007
1008 The same transformation is good when there are lets in the body:
1009
1010         /\abc -> let(rec) x = e in b
1011    ==>
1012         let(rec) x' = /\abc -> let x = x' a b c in e
1013         in 
1014         /\abc -> let x = x' a b c in b
1015
1016 This is good because it can turn things like:
1017
1018         let f = /\a -> letrec g = ... g ... in g
1019 into
1020         letrec g' = /\a -> ... g' a ...
1021         in
1022         let f = /\ a -> g' a
1023
1024 which is better.  In effect, it means that big lambdas don't impede
1025 let-floating.
1026
1027 This optimisation is CRUCIAL in eliminating the junk introduced by
1028 desugaring mutually recursive definitions.  Don't eliminate it lightly!
1029
1030 [May 1999]  If we do this transformation *regardless* then we can
1031 end up with some pretty silly stuff.  For example, 
1032
1033         let 
1034             st = /\ s -> let { x1=r1 ; x2=r2 } in ...
1035         in ..
1036 becomes
1037         let y1 = /\s -> r1
1038             y2 = /\s -> r2
1039             st = /\s -> ...[y1 s/x1, y2 s/x2]
1040         in ..
1041
1042 Unless the "..." is a WHNF there is really no point in doing this.
1043 Indeed it can make things worse.  Suppose x1 is used strictly,
1044 and is of the form
1045
1046         x1* = case f y of { (a,b) -> e }
1047
1048 If we abstract this wrt the tyvar we then can't do the case inline
1049 as we would normally do.
1050
1051 That's why the whole transformation is part of the same process that
1052 floats let-bindings and constructor arguments out of RHSs.  In particular,
1053 it is guarded by the doFloatFromRhs call in simplLazyBind.
1054
1055
1056 \begin{code}
1057 abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
1058 abstractFloats main_tvs body_env body
1059   = ASSERT( notNull body_floats )
1060     do  { (subst, float_binds) <- mapAccumLSmpl abstract empty_subst body_floats
1061         ; return (float_binds, CoreSubst.substExpr subst body) }
1062   where
1063     main_tv_set = mkVarSet main_tvs
1064     body_floats = getFloats body_env
1065     empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)
1066
1067     abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
1068     abstract subst (NonRec id rhs)
1069       = do { (poly_id, poly_app) <- mk_poly tvs_here id
1070            ; let poly_rhs = mkLams tvs_here rhs'
1071                  subst'   = CoreSubst.extendIdSubst subst id poly_app
1072            ; return (subst', (NonRec poly_id poly_rhs)) }
1073       where
1074         rhs' = CoreSubst.substExpr subst rhs
1075         tvs_here | any isCoVar main_tvs = main_tvs      -- Note [Abstract over coercions]
1076                  | otherwise 
1077                  = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
1078         
1079                 -- Abstract only over the type variables free in the rhs
1080                 -- wrt which the new binding is abstracted.  But the naive
1081                 -- approach of abstract wrt the tyvars free in the Id's type
1082                 -- fails. Consider:
1083                 --      /\ a b -> let t :: (a,b) = (e1, e2)
1084                 --                    x :: a     = fst t
1085                 --                in ...
1086                 -- Here, b isn't free in x's type, but we must nevertheless
1087                 -- abstract wrt b as well, because t's type mentions b.
1088                 -- Since t is floated too, we'd end up with the bogus:
1089                 --      poly_t = /\ a b -> (e1, e2)
1090                 --      poly_x = /\ a   -> fst (poly_t a *b*)
1091                 -- So for now we adopt the even more naive approach of
1092                 -- abstracting wrt *all* the tyvars.  We'll see if that
1093                 -- gives rise to problems.   SLPJ June 98
1094
1095     abstract subst (Rec prs)
1096        = do { (poly_ids, poly_apps) <- mapAndUnzipSmpl (mk_poly tvs_here) ids
1097             ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
1098                   poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
1099             ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
1100        where
1101          (ids,rhss) = unzip prs
1102                 -- For a recursive group, it's a bit of a pain to work out the minimal
1103                 -- set of tyvars over which to abstract:
1104                 --      /\ a b c.  let x = ...a... in
1105                 --                 letrec { p = ...x...q...
1106                 --                          q = .....p...b... } in
1107                 --                 ...
1108                 -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
1109                 -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.  
1110                 -- Since it's a pain, we just use the whole set, which is always safe
1111                 -- 
1112                 -- If you ever want to be more selective, remember this bizarre case too:
1113                 --      x::a = x
1114                 -- Here, we must abstract 'x' over 'a'.
1115          tvs_here = main_tvs
1116
1117     mk_poly tvs_here var
1118       = do { uniq <- getUniqueSmpl
1119            ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
1120                   poly_ty   = mkForAllTys tvs_here (idType var) -- But new type of course
1121                   poly_id   = mkLocalId poly_name poly_ty 
1122            ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
1123                 -- In the olden days, it was crucial to copy the occInfo of the original var, 
1124                 -- because we were looking at occurrence-analysed but as yet unsimplified code!
1125                 -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
1126                 -- at already simplified code, so it doesn't matter
1127                 -- 
1128                 -- It's even right to retain single-occurrence or dead-var info:
1129                 -- Suppose we started with  /\a -> let x = E in B
1130                 -- where x occurs once in B. Then we transform to:
1131                 --      let x' = /\a -> E in /\a -> let x* = x' a in B
1132                 -- where x* has an INLINE prag on it.  Now, once x* is inlined,
1133                 -- the occurrences of x' will be just the occurrences originally
1134                 -- pinned on x.
1135 \end{code}
1136
1137 Note [Abstract over coercions]
1138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1139 If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
1140 type variable a.  Rather than sort this mess out, we simply bale out and abstract
1141 wrt all the type variables if any of them are coercion variables.
1142
1143
1144 Historical note: if you use let-bindings instead of a substitution, beware of this:
1145
1146                 -- Suppose we start with:
1147                 --
1148                 --      x = /\ a -> let g = G in E
1149                 --
1150                 -- Then we'll float to get
1151                 --
1152                 --      x = let poly_g = /\ a -> G
1153                 --          in /\ a -> let g = poly_g a in E
1154                 --
1155                 -- But now the occurrence analyser will see just one occurrence
1156                 -- of poly_g, not inside a lambda, so the simplifier will
1157                 -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
1158                 -- (I used to think that the "don't inline lone occurrences" stuff
1159                 --  would stop this happening, but since it's the *only* occurrence,
1160                 --  PreInlineUnconditionally kicks in first!)
1161                 --
1162                 -- Solution: put an INLINE note on g's RHS, so that poly_g seems
1163                 --           to appear many times.  (NB: mkInlineMe eliminates
1164                 --           such notes on trivial RHSs, so do it manually.)
1165
1166 %************************************************************************
1167 %*                                                                      *
1168                 prepareAlts
1169 %*                                                                      *
1170 %************************************************************************
1171
1172 prepareAlts tries these things:
1173
1174 1.  If several alternatives are identical, merge them into
1175     a single DEFAULT alternative.  I've occasionally seen this 
1176     making a big difference:
1177
1178         case e of               =====>     case e of
1179           C _ -> f x                         D v -> ....v....
1180           D v -> ....v....                   DEFAULT -> f x
1181           DEFAULT -> f x
1182
1183    The point is that we merge common RHSs, at least for the DEFAULT case.
1184    [One could do something more elaborate but I've never seen it needed.]
1185    To avoid an expensive test, we just merge branches equal to the *first*
1186    alternative; this picks up the common cases
1187         a) all branches equal
1188         b) some branches equal to the DEFAULT (which occurs first)
1189
1190 2.  Case merging:
1191        case e of b {             ==>   case e of b {
1192          p1 -> rhs1                      p1 -> rhs1
1193          ...                             ...
1194          pm -> rhsm                      pm -> rhsm
1195          _  -> case b of b' {            pn -> let b'=b in rhsn
1196                      pn -> rhsn          ...
1197                      ...                 po -> let b'=b in rhso
1198                      po -> rhso          _  -> let b'=b in rhsd
1199                      _  -> rhsd
1200        }  
1201     
1202     which merges two cases in one case when -- the default alternative of
1203     the outer case scrutises the same variable as the outer case This
1204     transformation is called Case Merging.  It avoids that the same
1205     variable is scrutinised multiple times.
1206
1207
1208 The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
1209
1210         x | p `is` 1 -> e1
1211           | p `is` 2 -> e2
1212         ...etc...
1213
1214 where @is@ was something like
1215         
1216         p `is` n = p /= (-1) && p == n
1217
1218 This gave rise to a horrible sequence of cases
1219
1220         case p of
1221           (-1) -> $j p
1222           1    -> e1
1223           DEFAULT -> $j p
1224
1225 and similarly in cascade for all the join points!
1226
1227 Note [Dead binders]
1228 ~~~~~~~~~~~~~~~~~~~~
1229 We do this *here*, looking at un-simplified alternatives, because we
1230 have to check that r doesn't mention the variables bound by the
1231 pattern in each alternative, so the binder-info is rather useful.
1232
1233 \begin{code}
1234 prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
1235 prepareAlts scrut case_bndr' alts
1236   = do  { dflags <- getDOptsSmpl
1237         ; alts <- combineIdenticalAlts case_bndr' alts
1238
1239         ; let (alts_wo_default, maybe_deflt) = findDefault alts
1240               alt_cons = [con | (con,_,_) <- alts_wo_default]
1241               imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
1242                 -- "imposs_deflt_cons" are handled 
1243                 --   EITHER by the context, 
1244                 --   OR by a non-DEFAULT branch in this case expression.
1245
1246         ; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app 
1247                                          imposs_deflt_cons maybe_deflt
1248
1249         ; let trimmed_alts = filterOut impossible_alt alts_wo_default
1250               merged_alts = mergeAlts trimmed_alts default_alts
1251                 -- We need the mergeAlts in case the new default_alt 
1252                 -- has turned into a constructor alternative.
1253                 -- The merge keeps the inner DEFAULT at the front, if there is one
1254                 -- and interleaves the alternatives in the right order
1255
1256         ; return (imposs_deflt_cons, merged_alts) }
1257   where
1258     mb_tc_app = splitTyConApp_maybe (idType case_bndr')
1259     Just (_, inst_tys) = mb_tc_app 
1260
1261     imposs_cons = case scrut of
1262                     Var v -> otherCons (idUnfolding v)
1263                     other -> []
1264
1265     impossible_alt :: CoreAlt -> Bool
1266     impossible_alt (con, _, _) | con `elem` imposs_cons = True
1267     impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
1268     impossible_alt alt                 = False
1269
1270
1271 --------------------------------------------------
1272 --      1. Merge identical branches
1273 --------------------------------------------------
1274 combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
1275
1276 combineIdenticalAlts case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
1277   | all isDeadBinder bndrs1,                    -- Remember the default 
1278     length filtered_alts < length con_alts      -- alternative comes first
1279         -- Also Note [Dead binders]
1280   = do  { tick (AltMerge case_bndr)
1281         ; return ((DEFAULT, [], rhs1) : filtered_alts) }
1282   where
1283     filtered_alts        = filter keep con_alts
1284     keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
1285
1286 combineIdenticalAlts case_bndr alts = return alts
1287
1288 -------------------------------------------------------------------------
1289 --                      Prepare the default alternative
1290 -------------------------------------------------------------------------
1291 prepareDefault :: DynFlags
1292                -> OutExpr       -- Scrutinee
1293                -> OutId         -- Case binder; need just for its type. Note that as an
1294                                 --   OutId, it has maximum information; this is important.
1295                                 --   Test simpl013 is an example
1296                -> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed
1297                -> [AltCon]      -- These cons can't happen when matching the default
1298                -> Maybe InExpr  -- Rhs
1299                -> SimplM [InAlt]        -- Still unsimplified
1300                                         -- We use a list because it's what mergeAlts expects,
1301                                         -- And becuase case-merging can cause many to show up
1302
1303 ------- Merge nested cases ----------
1304 prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs)
1305   | dopt Opt_CaseMerge dflags
1306   , Case (Var scrut_var) inner_bndr _ inner_alts <- deflt_rhs
1307   , scruting_same_var scrut_var
1308   = do  { tick (CaseMerge outer_bndr)
1309
1310         ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
1311         ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts,
1312                                                not (con `elem` imposs_cons) ]
1313                 -- NB: filter out any imposs_cons.  Example:
1314                 --      case x of 
1315                 --        A -> e1
1316                 --        DEFAULT -> case x of 
1317                 --                      A -> e2
1318                 --                      B -> e3
1319                 -- When we merge, we must ensure that e1 takes 
1320                 -- precedence over e2 as the value for A!  
1321         }
1322         -- Warning: don't call prepareAlts recursively!
1323         -- Firstly, there's no point, because inner alts have already had
1324         -- mkCase applied to them, so they won't have a case in their default
1325         -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
1326         -- in munge_rhs may put a case into the DEFAULT branch!
1327   where
1328         -- We are scrutinising the same variable if it's
1329         -- the outer case-binder, or if the outer case scrutinises a variable
1330         -- (and it's the same).  Testing both allows us not to replace the
1331         -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
1332     scruting_same_var = case scrut of
1333                           Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
1334                           other           -> \ v -> v == outer_bndr
1335
1336 --------- Fill in known constructor -----------
1337 prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
1338   |     -- This branch handles the case where we are 
1339         -- scrutinisng an algebraic data type
1340     isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.  
1341   , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:
1342                                 --      case x of { DEFAULT -> e }
1343                                 -- and we don't want to fill in a default for them!
1344   , Just all_cons <- tyConDataCons_maybe tycon
1345   , not (null all_cons)         -- This is a tricky corner case.  If the data type has no constructors,
1346                                 -- which GHC allows, then the case expression will have at most a default
1347                                 -- alternative.  We don't want to eliminate that alternative, because the
1348                                 -- invariant is that there's always one alternative.  It's more convenient
1349                                 -- to leave     
1350                                 --      case x of { DEFAULT -> e }     
1351                                 -- as it is, rather than transform it to
1352                                 --      error "case cant match"
1353                                 -- which would be quite legitmate.  But it's a really obscure corner, and
1354                                 -- not worth wasting code on.
1355   , let imposs_data_cons = [con | DataAlt con <- imposs_cons]   -- We now know it's a data type 
1356         impossible con  = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
1357   = case filterOut impossible all_cons of
1358         []    -> return []      -- Eliminate the default alternative
1359                                 -- altogether if it can't match
1360
1361         [con] ->        -- It matches exactly one constructor, so fill it in
1362                  do { tick (FillInCaseDefault case_bndr)
1363                     ; us <- getUniquesSmpl
1364                     ; let (ex_tvs, co_tvs, arg_ids) =
1365                               dataConRepInstPat us con inst_tys
1366                     ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
1367
1368         two_or_more -> return [(DEFAULT, [], deflt_rhs)]
1369
1370 --------- Catch-all cases -----------
1371 prepareDefault dflags scrut case_bndr bndr_ty imposs_cons (Just deflt_rhs)
1372   = return [(DEFAULT, [], deflt_rhs)]
1373
1374 prepareDefault dflags scrut case_bndr bndr_ty imposs_cons Nothing
1375   = return []   -- No default branch
1376 \end{code}
1377
1378
1379
1380 =================================================================================
1381
1382 mkCase tries these things
1383
1384 1.  Eliminate the case altogether if possible
1385
1386 2.  Case-identity:
1387
1388         case e of               ===> e
1389                 True  -> True;
1390                 False -> False
1391
1392     and similar friends.
1393
1394
1395 \begin{code}
1396 mkCase :: OutExpr -> OutId -> OutType
1397        -> [OutAlt]              -- Increasing order
1398        -> SimplM OutExpr
1399
1400 --------------------------------------------------
1401 --      1. Check for empty alternatives
1402 --------------------------------------------------
1403
1404 -- This isn't strictly an error.  It's possible that the simplifer might "see"
1405 -- that an inner case has no accessible alternatives before it "sees" that the
1406 -- entire branch of an outer case is inaccessible.  So we simply
1407 -- put an error case here insteadd
1408 mkCase scrut case_bndr ty []
1409   = pprTrace "mkCase: null alts" (ppr case_bndr <+> ppr scrut) $
1410     return (mkApps (Var rUNTIME_ERROR_ID)
1411                    [Type ty, Lit (mkStringLit "Impossible alternative")])
1412
1413
1414 --------------------------------------------------
1415 --      2. Identity case
1416 --------------------------------------------------
1417
1418 mkCase scrut case_bndr ty alts  -- Identity case
1419   | all identity_alt alts
1420   = tick (CaseIdentity case_bndr)               `thenSmpl_`
1421     returnSmpl (re_cast scrut)
1422   where
1423     identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
1424
1425     check_eq DEFAULT       _    (Var v)   = v == case_bndr
1426     check_eq (LitAlt lit') _    (Lit lit) = lit == lit'
1427     check_eq (DataAlt con) args rhs       = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
1428                                          || rhs `cheapEqExpr` Var case_bndr
1429     check_eq con args rhs = False
1430
1431     arg_tys = map Type (tyConAppArgs (idType case_bndr))
1432
1433         -- We've seen this:
1434         --      case e of x { _ -> x `cast` c }
1435         -- And we definitely want to eliminate this case, to give
1436         --      e `cast` c
1437         -- So we throw away the cast from the RHS, and reconstruct
1438         -- it at the other end.  All the RHS casts must be the same
1439         -- if (all identity_alt alts) holds.
1440         -- 
1441         -- Don't worry about nested casts, because the simplifier combines them
1442     de_cast (Cast e _) = e
1443     de_cast e          = e
1444
1445     re_cast scrut = case head alts of
1446                         (_,_,Cast _ co) -> Cast scrut co
1447                         other           -> scrut
1448
1449
1450
1451 --------------------------------------------------
1452 --      Catch-all
1453 --------------------------------------------------
1454 mkCase scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
1455 \end{code}
1456
1457
1458 When adding auxiliary bindings for the case binder, it's worth checking if
1459 its dead, because it often is, and occasionally these mkCase transformations
1460 cascade rather nicely.
1461
1462 \begin{code}
1463 bindCaseBndr bndr rhs body
1464   | isDeadBinder bndr = body
1465   | otherwise         = bindNonRec bndr rhs body
1466 \end{code}