Comments only
[ghc.git] / compiler / specialise / SpecConstr.lhs
1 ToDo [Nov 2010]
2 ~~~~~~~~~~~~~~~
3 1. Use a library type rather than an annotation for ForceSpecConstr
4 2. Nuke NoSpecConstr
5
6 %
7 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
8 %
9 \section[SpecConstr]{Specialise over constructors}
10
11 \begin{code}
12 module SpecConstr(
13         specConstrProgram
14 #ifdef GHCI
15         , SpecConstrAnnotation(..)
16 #endif
17     ) where
18
19 #include "HsVersions.h"
20
21 import CoreSyn
22 import CoreSubst
23 import CoreUtils
24 import CoreUnfold       ( couldBeSmallEnoughToInline )
25 import CoreFVs          ( exprsFreeVars )
26 import CoreMonad
27 import Literal          ( litIsLifted )
28 import HscTypes         ( ModGuts(..) )
29 import WwLib            ( mkWorkerArgs )
30 import DataCon
31 import Coercion         hiding( substTy, substCo )
32 import Rules
33 import Type             hiding ( substTy )
34 import TyCon            ( isRecursiveTyCon )
35 import Id
36 import MkCore           ( mkImpossibleExpr )
37 import Var
38 import VarEnv
39 import VarSet
40 import Name
41 import BasicTypes
42 import DynFlags         ( DynFlags(..) )
43 import StaticFlags      ( opt_PprStyle_Debug )
44 import Maybes           ( orElse, catMaybes, isJust, isNothing )
45 import Demand
46 import Serialized       ( deserializeWithData )
47 import Util
48 import Pair
49 import UniqSupply
50 import Outputable
51 import FastString
52 import UniqFM
53 import MonadUtils
54 import Control.Monad    ( zipWithM )
55 import Data.List
56
57
58 -- See Note [SpecConstrAnnotation]
59 #ifndef GHCI
60 type SpecConstrAnnotation = ()
61 #else
62 import TyCon            ( TyCon )
63 import GHC.Exts( SpecConstrAnnotation(..) )
64 #endif
65 \end{code}
66
67 -----------------------------------------------------
68                         Game plan
69 -----------------------------------------------------
70
71 Consider
72         drop n []     = []
73         drop 0 xs     = []
74         drop n (x:xs) = drop (n-1) xs
75
76 After the first time round, we could pass n unboxed.  This happens in
77 numerical code too.  Here's what it looks like in Core:
78
79         drop n xs = case xs of
80                       []     -> []
81                       (y:ys) -> case n of
82                                   I# n# -> case n# of
83                                              0 -> []
84                                              _ -> drop (I# (n# -# 1#)) xs
85
86 Notice that the recursive call has an explicit constructor as argument.
87 Noticing this, we can make a specialised version of drop
88
89         RULE: drop (I# n#) xs ==> drop' n# xs
90
91         drop' n# xs = let n = I# n# in ...orig RHS...
92
93 Now the simplifier will apply the specialisation in the rhs of drop', giving
94
95         drop' n# xs = case xs of
96                       []     -> []
97                       (y:ys) -> case n# of
98                                   0 -> []
99                                   _ -> drop' (n# -# 1#) xs
100
101 Much better!
102
103 We'd also like to catch cases where a parameter is carried along unchanged,
104 but evaluated each time round the loop:
105
106         f i n = if i>0 || i>n then i else f (i*2) n
107
108 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
109 In Core, by the time we've w/wd (f is strict in i) we get
110
111         f i# n = case i# ># 0 of
112                    False -> I# i#
113                    True  -> case n of { I# n# ->
114                             case i# ># n# of
115                                 False -> I# i#
116                                 True  -> f (i# *# 2#) n
117
118 At the call to f, we see that the argument, n is known to be (I# n#),
119 and n is evaluated elsewhere in the body of f, so we can play the same
120 trick as above.
121
122
123 Note [Reboxing]
124 ~~~~~~~~~~~~~~~
125 We must be careful not to allocate the same constructor twice.  Consider
126         f p = (...(case p of (a,b) -> e)...p...,
127                ...let t = (r,s) in ...t...(f t)...)
128 At the recursive call to f, we can see that t is a pair.  But we do NOT want
129 to make a specialised copy:
130         f' a b = let p = (a,b) in (..., ...)
131 because now t is allocated by the caller, then r and s are passed to the
132 recursive call, which allocates the (r,s) pair again.
133
134 This happens if
135   (a) the argument p is used in other than a case-scrutinisation way.
136   (b) the argument to the call is not a 'fresh' tuple; you have to
137         look into its unfolding to see that it's a tuple
138
139 Hence the "OR" part of Note [Good arguments] below.
140
141 ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
142 allocation, but does perhaps save evals. In the RULE we'd have
143 something like
144
145   f (I# x#) = f' (I# x#) x#
146
147 If at the call site the (I# x) was an unfolding, then we'd have to
148 rely on CSE to eliminate the duplicate allocation.... This alternative
149 doesn't look attractive enough to pursue.
150
151 ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that
152 the conservative reboxing story prevents many useful functions from being
153 specialised.  Example:
154         foo :: Maybe Int -> Int -> Int
155         foo   (Just m) 0 = 0
156         foo x@(Just m) n = foo x (n-m)
157 Here the use of 'x' will clearly not require boxing in the specialised function.
158
159 The strictness analyser has the same problem, in fact.  Example:
160         f p@(a,b) = ...
161 If we pass just 'a' and 'b' to the worker, it might need to rebox the
162 pair to create (a,b).  A more sophisticated analysis might figure out
163 precisely the cases in which this could happen, but the strictness
164 analyser does no such analysis; it just passes 'a' and 'b', and hopes
165 for the best.
166
167 So my current choice is to make SpecConstr similarly aggressive, and
168 ignore the bad potential of reboxing.
169
170
171 Note [Good arguments]
172 ~~~~~~~~~~~~~~~~~~~~~
173 So we look for
174
175 * A self-recursive function.  Ignore mutual recursion for now,
176   because it's less common, and the code is simpler for self-recursion.
177
178 * EITHER
179
180    a) At a recursive call, one or more parameters is an explicit
181       constructor application
182         AND
183       That same parameter is scrutinised by a case somewhere in
184       the RHS of the function
185
186   OR
187
188     b) At a recursive call, one or more parameters has an unfolding
189        that is an explicit constructor application
190         AND
191       That same parameter is scrutinised by a case somewhere in
192       the RHS of the function
193         AND
194       Those are the only uses of the parameter (see Note [Reboxing])
195
196
197 What to abstract over
198 ~~~~~~~~~~~~~~~~~~~~~
199 There's a bit of a complication with type arguments.  If the call
200 site looks like
201
202         f p = ...f ((:) [a] x xs)...
203
204 then our specialised function look like
205
206         f_spec x xs = let p = (:) [a] x xs in ....as before....
207
208 This only makes sense if either
209   a) the type variable 'a' is in scope at the top of f, or
210   b) the type variable 'a' is an argument to f (and hence fs)
211
212 Actually, (a) may hold for value arguments too, in which case
213 we may not want to pass them.  Supose 'x' is in scope at f's
214 defn, but xs is not.  Then we'd like
215
216         f_spec xs = let p = (:) [a] x xs in ....as before....
217
218 Similarly (b) may hold too.  If x is already an argument at the
219 call, no need to pass it again.
220
221 Finally, if 'a' is not in scope at the call site, we could abstract
222 it as we do the term variables:
223
224         f_spec a x xs = let p = (:) [a] x xs in ...as before...
225
226 So the grand plan is:
227
228         * abstract the call site to a constructor-only pattern
229           e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
230
231         * Find the free variables of the abstracted pattern
232
233         * Pass these variables, less any that are in scope at
234           the fn defn.  But see Note [Shadowing] below.
235
236
237 NOTICE that we only abstract over variables that are not in scope,
238 so we're in no danger of shadowing variables used in "higher up"
239 in f_spec's RHS.
240
241
242 Note [Shadowing]
243 ~~~~~~~~~~~~~~~~
244 In this pass we gather up usage information that may mention variables
245 that are bound between the usage site and the definition site; or (more
246 seriously) may be bound to something different at the definition site.
247 For example:
248
249         f x = letrec g y v = let x = ...
250                              in ...(g (a,b) x)...
251
252 Since 'x' is in scope at the call site, we may make a rewrite rule that
253 looks like
254         RULE forall a,b. g (a,b) x = ...
255 But this rule will never match, because it's really a different 'x' at
256 the call site -- and that difference will be manifest by the time the
257 simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
258 no-shadowing, so perhaps it may not be distinct?]
259
260 Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
261 is to run deShadowBinds before running SpecConstr, but instead we run the
262 simplifier.  That gives the simplest possible program for SpecConstr to
263 chew on; and it virtually guarantees no shadowing.
264
265 Note [Specialising for constant parameters]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 This one is about specialising on a *constant* (but not necessarily
268 constructor) argument
269
270     foo :: Int -> (Int -> Int) -> Int
271     foo 0 f = 0
272     foo m f = foo (f m) (+1)
273
274 It produces
275
276     lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
277     lvl_rmV =
278       \ (ds_dlk :: GHC.Base.Int) ->
279         case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
280         GHC.Base.I# (GHC.Prim.+# x_alG 1)
281
282     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
283     GHC.Prim.Int#
284     T.$wfoo =
285       \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
286         case ww_sme of ds_Xlw {
287           __DEFAULT ->
288         case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
289         T.$wfoo ww1_Xmz lvl_rmV
290         };
291           0 -> 0
292         }
293
294 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
295 with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
296
297 When is this worth it?  Call the constant 'lvl'
298 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
299   parameter is scrutinised anywhere in the body.
300
301 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
302   parameter is applied (...to enough arguments...?)
303
304   Also do this is if the function has RULES?
305
306 Also
307
308 Note [Specialising for lambda parameters]
309 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
310     foo :: Int -> (Int -> Int) -> Int
311     foo 0 f = 0
312     foo m f = foo (f m) (\n -> n-m)
313
314 This is subtly different from the previous one in that we get an
315 explicit lambda as the argument:
316
317     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
318     GHC.Prim.Int#
319     T.$wfoo =
320       \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
321         case ww_sm8 of ds_Xlr {
322           __DEFAULT ->
323         case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
324         T.$wfoo
325           ww1_Xmq
326           (\ (n_ad3 :: GHC.Base.Int) ->
327              case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
328              GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
329              })
330         };
331           0 -> 0
332         }
333
334 I wonder if SpecConstr couldn't be extended to handle this? After all,
335 lambda is a sort of constructor for functions and perhaps it already
336 has most of the necessary machinery?
337
338 Furthermore, there's an immediate win, because you don't need to allocate the lamda
339 at the call site; and if perchance it's called in the recursive call, then you
340 may avoid allocating it altogether.  Just like for constructors.
341
342 Looks cool, but probably rare...but it might be easy to implement.
343
344
345 Note [SpecConstr for casts]
346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
347 Consider
348     data family T a :: *
349     data instance T Int = T Int
350
351     foo n = ...
352        where
353          go (T 0) = 0
354          go (T n) = go (T (n-1))
355
356 The recursive call ends up looking like
357         go (T (I# ...) `cast` g)
358 So we want to spot the constructor application inside the cast.
359 That's why we have the Cast case in argToPat
360
361 Note [Local recursive groups]
362 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 For a *local* recursive group, we can see all the calls to the
364 function, so we seed the specialisation loop from the calls in the
365 body, not from the calls in the RHS.  Consider:
366
367   bar m n = foo n (n,n) (n,n) (n,n) (n,n)
368    where
369      foo n p q r s
370        | n == 0    = m
371        | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
372        | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
373        | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
374        | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
375
376 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
377 most of which are not needed.  But if we start with the (single) call
378 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
379 the recursive calls go to this fully-specialised copy. Indeed, the original
380 function is later collected as dead code.  This is very important in
381 specialising the loops arising from stream fusion, for example in NDP where
382 we were getting literally hundreds of (mostly unused) specialisations of
383 a local function.
384
385 In a case like the above we end up never calling the original un-specialised
386 function.  (Although we still leave its code around just in case.)
387
388 However, if we find any boring calls in the body, including *unsaturated*
389 ones, such as
390       letrec foo x y = ....foo...
391       in map foo xs
392 then we will end up calling the un-specialised function, so then we *should*
393 use the calls in the un-specialised RHS as seeds.  We call these
394 "boring call patterns", and callsToPats reports if it finds any of these.
395
396
397 Note [Top-level recursive groups]
398 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
399 If all the bindings in a top-level recursive group are not exported,
400 all the calls are in the rest of the top-level bindings.
401 This means we can specialise with those call patterns instead of with the RHSs
402 of the recursive group.
403
404 To get the call usage information, we work backwards through the top-level bindings
405 so we see the usage before we get to the binding of the function.
406 Before we can collect the usage though, we go through all the bindings and add them
407 to the environment. This is necessary because usage is only tracked for functions
408 in the environment.
409
410 The actual seeding of the specialisation is very similar to Note [Local recursive group].
411
412
413 Note [Do not specialise diverging functions]
414 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
415 Specialising a function that just diverges is a waste of code.
416 Furthermore, it broke GHC (simpl014) thus:
417    {-# STR Sb #-}
418    f = \x. case x of (a,b) -> f x
419 If we specialise f we get
420    f = \x. case x of (a,b) -> fspec a b
421 But fspec doesn't have decent strictness info.  As it happened,
422 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
423 and hence f.  But now f's strictness is less than its arity, which
424 breaks an invariant.
425
426 Note [SpecConstrAnnotation]
427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
428 SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
429 be available in stage 2 (well, until the bootstrap compiler can be
430 guaranteed to have it)
431
432 So we define it to be () in stage1 (ie when GHCI is undefined), and
433 '#ifdef' out the code that uses it.
434
435 See also Note [Forcing specialisation]
436
437 Note [Forcing specialisation]
438 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
439 With stream fusion and in other similar cases, we want to fully specialise
440 some (but not necessarily all!) loops regardless of their size and the
441 number of specialisations. We allow a library to specify this by annotating
442 a type with ForceSpecConstr and then adding a parameter of that type to the
443 loop. Here is a (simplified) example from the vector library:
444
445   data SPEC = SPEC | SPEC2
446   {-# ANN type SPEC ForceSpecConstr #-}
447
448   foldl :: (a -> b -> a) -> a -> Stream b -> a
449   {-# INLINE foldl #-}
450   foldl f z (Stream step s _) = foldl_loop SPEC z s
451     where
452       foldl_loop !sPEC z s = case step s of
453                               Yield x s' -> foldl_loop sPEC (f z x) s'
454                               Skip       -> foldl_loop sPEC z s'
455                               Done       -> z
456
457 SpecConstr will spot the SPEC parameter and always fully specialise
458 foldl_loop. Note that
459
460   * We have to prevent the SPEC argument from being removed by
461     w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
462     the SPEC argument.
463
464   * And lastly, the SPEC argument is ultimately eliminated by
465     SpecConstr itself so there is no runtime overhead.
466
467 This is all quite ugly; we ought to come up with a better design.
468
469 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
470 sc_force to True when calling specLoop. This flag does four things:
471   * Ignore specConstrThreshold, to specialise functions of arbitrary size
472         (see scTopBind)
473   * Ignore specConstrCount, to make arbitrary numbers of specialisations
474         (see specialise)
475   * Specialise even for arguments that are not scrutinised in the loop
476         (see argToPat; Trac #4488)
477   * Only specialise on recursive types a finite number of times
478         (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation])
479
480 This flag is inherited for nested non-recursive bindings (which are likely to
481 be join points and hence should be fully specialised) but reset for nested
482 recursive bindings.
483
484 What alternatives did I consider? Annotating the loop itself doesn't
485 work because (a) it is local and (b) it will be w/w'ed and having
486 w/w propagating annotations somehow doesn't seem like a good idea. The
487 types of the loop arguments really seem to be the most persistent
488 thing.
489
490 Annotating the types that make up the loop state doesn't work,
491 either, because (a) it would prevent us from using types like Either
492 or tuples here, (b) we don't want to restrict the set of types that
493 can be used in Stream states and (c) some types are fixed by the user
494 (e.g., the accumulator here) but we still want to specialise as much
495 as possible.
496
497 ForceSpecConstr is done by way of an annotation:
498   data SPEC = SPEC | SPEC2
499   {-# ANN type SPEC ForceSpecConstr #-}
500 But SPEC is the *only* type so annotated, so it'd be better to
501 use a particular library type.
502
503 Alternatives to ForceSpecConstr
504 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
505 Instead of giving the loop an extra argument of type SPEC, we
506 also considered *wrapping* arguments in SPEC, thus
507   data SPEC a = SPEC a | SPEC2
508
509   loop = \arg -> case arg of
510                      SPEC state ->
511                         case state of (x,y) -> ... loop (SPEC (x',y')) ...
512                         S2 -> error ...
513 The idea is that a SPEC argument says "specialise this argument
514 regardless of whether the function case-analyses it".  But this
515 doesn't work well:
516   * SPEC must still be a sum type, else the strictness analyser
517     eliminates it
518   * But that means that 'loop' won't be strict in its real payload
519 This loss of strictness in turn screws up specialisation, because
520 we may end up with calls like
521    loop (SPEC (case z of (p,q) -> (q,p)))
522 Without the SPEC, if 'loop' were strict, the case would move out
523 and we'd see loop applied to a pair. But if 'loop' isn't strict
524 this doesn't look like a specialisable call.
525
526 Note [Limit recursive specialisation]
527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
528 It is possible for ForceSpecConstr to cause an infinite loop of specialisation.
529 Because there is no limit on the number of specialisations, a recursive call with
530 a recursive constructor as an argument (for example, list cons) will generate
531 a specialisation for that constructor. If the resulting specialisation also
532 contains a recursive call with the constructor, this could proceed indefinitely.
533
534 For example, if ForceSpecConstr is on:
535   loop :: [Int] -> [Int] -> [Int]
536   loop z []         = z
537   loop z (x:xs)     = loop (x:z) xs
538 this example will create a specialisation for the pattern
539   loop (a:b) c      = loop' a b c
540
541   loop' a b []      = (a:b)
542   loop' a b (x:xs)  = loop (x:(a:b)) xs
543 and a new pattern is found:
544   loop (a:(b:c)) d  = loop'' a b c d
545 which can continue indefinitely.
546
547 Roman's suggestion to fix this was to stop after a couple of times on recursive types,
548 but still specialising on non-recursive types as much as possible.
549
550 To implement this, we count the number of recursive constructors in each
551 function argument. If the maximum is greater than the specConstrRecursive limit,
552 do not specialise on that pattern.
553
554 This is only necessary when ForceSpecConstr is on: otherwise the specConstrCount
555 will force termination anyway.
556
557 See Trac #5550.
558
559 Note [NoSpecConstr]
560 ~~~~~~~~~~~~~~~~~~~
561 The ignoreDataCon stuff allows you to say
562     {-# ANN type T NoSpecConstr #-}
563 to mean "don't specialise on arguments of this type.  It was added
564 before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised
565 regardless of size; and then we needed a way to turn that *off*.  Now
566 that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
567 (Used only for PArray.)
568
569 -----------------------------------------------------
570                 Stuff not yet handled
571 -----------------------------------------------------
572
573 Here are notes arising from Roman's work that I don't want to lose.
574
575 Example 1
576 ~~~~~~~~~
577     data T a = T !a
578
579     foo :: Int -> T Int -> Int
580     foo 0 t = 0
581     foo x t | even x    = case t of { T n -> foo (x-n) t }
582             | otherwise = foo (x-1) t
583
584 SpecConstr does no specialisation, because the second recursive call
585 looks like a boxed use of the argument.  A pity.
586
587     $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
588     $wfoo_sFw =
589       \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
590          case ww_sFo of ds_Xw6 [Just L] {
591            __DEFAULT ->
592                 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
593                   __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
594                   0 ->
595                     case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
596                     case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
597                     $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
598                     } } };
599            0 -> 0
600
601 Example 2
602 ~~~~~~~~~
603     data a :*: b = !a :*: !b
604     data T a = T !a
605
606     foo :: (Int :*: T Int) -> Int
607     foo (0 :*: t) = 0
608     foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
609                   | otherwise = foo ((x-1) :*: t)
610
611 Very similar to the previous one, except that the parameters are now in
612 a strict tuple. Before SpecConstr, we have
613
614     $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
615     $wfoo_sG3 =
616       \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
617     GHC.Base.Int) ->
618         case ww_sFU of ds_Xws [Just L] {
619           __DEFAULT ->
620         case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
621           __DEFAULT ->
622             case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
623             $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
624             };
625           0 ->
626             case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
627             case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
628             $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
629             } } };
630           0 -> 0 }
631
632 We get two specialisations:
633 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
634                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
635                   = Foo.$s$wfoo1 a_sFB sc_sGC ;
636 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
637                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
638                   = Foo.$s$wfoo y_aFp sc_sGC ;
639
640 But perhaps the first one isn't good.  After all, we know that tpl_B2 is
641 a T (I# x) really, because T is strict and Int has one constructor.  (We can't
642 unbox the strict fields, because T is polymorphic!)
643
644 %************************************************************************
645 %*                                                                      *
646 \subsection{Top level wrapper stuff}
647 %*                                                                      *
648 %************************************************************************
649
650 \begin{code}
651 specConstrProgram :: ModGuts -> CoreM ModGuts
652 specConstrProgram guts
653   = do
654       dflags <- getDynFlags
655       us     <- getUniqueSupplyM
656       annos  <- getFirstAnnotations deserializeWithData guts
657       let binds' = reverse $ fst $ initUs us $ do
658                     -- Note [Top-level recursive groups]
659                     (env, binds) <- goEnv (initScEnv dflags annos) (mg_binds guts)
660                     go env nullUsage (reverse binds)
661
662       return (guts { mg_binds = binds' })
663   where
664     goEnv env []            = return (env, [])
665     goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind
666                                  (env'', binds') <- goEnv env' binds
667                                  return (env'', bind' : binds')
668
669     go _   _   []           = return []
670     go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind
671                                  binds' <- go env usg' binds
672                                  return (bind' : binds')
673 \end{code}
674
675
676 %************************************************************************
677 %*                                                                      *
678 \subsection{Environment: goes downwards}
679 %*                                                                      *
680 %************************************************************************
681
682 Note [Work-free values only in environment]
683 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
684 The sc_vals field keeps track of in-scope value bindings, so 
685 that if we come across (case x of Just y ->...) we can reduce the
686 case from knowing that x is bound to a pair.
687
688 But only *work-free* values are ok here. For example if the envt had
689     x -> Just (expensive v)
690 then we do NOT want to expand to
691      let y = expensive v in ...
692 because the x-binding still exists and we've now duplicated (expensive v).
693
694 This seldom happens because let-bound constructor applications are 
695 ANF-ised, but it can happen as a result of on-the-fly transformations in
696 SpecConstr itself.  Here is Trac #7865:
697
698         let {
699           a'_shr =
700             case xs_af8 of _ {
701               [] -> acc_af6;
702               : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->
703                 (expensive x_af7, x_af7
704             } } in
705         let {
706           ds_sht =
707             case a'_shr of _ { (p'_afd, q'_afe) ->
708             TSpecConstr_DoubleInline.recursive
709               (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)
710             } } in
711
712 When processed knowing that xs_af8 was bound to a cons, we simplify to 
713    a'_shr = (expensive x_af7, x_af7)
714 and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.
715 (There are other occurrences of a'_shr.)  No no no.
716
717 It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned
718 into a work-free value again, thus
719    a1 = expensive x_af7
720    a'_shr = (a1, x_af7)
721 but that's more work, so until its shown to be important I'm going to 
722 leave it for now.
723
724 \begin{code}
725 data ScEnv = SCE { sc_dflags    :: DynFlags,
726                    sc_size      :: Maybe Int,   -- Size threshold
727                    sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn
728                                                 -- See Note [Avoiding exponential blowup]
729
730                    sc_recursive :: Int,         -- Max # of specialisations over recursive type.
731                                                 -- Stops ForceSpecConstr from diverging.
732
733                    sc_force     :: Bool,        -- Force specialisation?
734                                                 -- See Note [Forcing specialisation]
735
736                    sc_subst     :: Subst,       -- Current substitution
737                                                 -- Maps InIds to OutExprs
738
739                    sc_how_bound :: HowBoundEnv,
740                         -- Binds interesting non-top-level variables
741                         -- Domain is OutVars (*after* applying the substitution)
742
743                    sc_vals      :: ValueEnv,
744                         -- Domain is OutIds (*after* applying the substitution)
745                         -- Used even for top-level bindings (but not imported ones)
746                         -- The range of the ValueEnv is *work-free* values
747                         -- such as (\x. blah), or (Just v)
748                         -- but NOT (Just (expensive v))
749                         -- See Note [Work-free values only in environment]
750
751                    sc_annotations :: UniqFM SpecConstrAnnotation
752              }
753
754 ---------------------
755 -- As we go, we apply a substitution (sc_subst) to the current term
756 type InExpr = CoreExpr          -- _Before_ applying the subst
757 type InVar  = Var
758
759 type OutExpr = CoreExpr         -- _After_ applying the subst
760 type OutId   = Id
761 type OutVar  = Var
762
763 ---------------------
764 type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
765
766 ---------------------
767 type ValueEnv = IdEnv Value             -- Domain is OutIds
768 data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
769                                         --   The AltCon is never DEFAULT
770               | LambdaVal               -- Inlinable lambdas or PAPs
771
772 instance Outputable Value where
773    ppr (ConVal con args) = ppr con <+> interpp'SP args
774    ppr LambdaVal         = ptext (sLit "<Lambda>")
775
776 ---------------------
777 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
778 initScEnv dflags anns
779   = SCE { sc_dflags      = dflags,
780           sc_size        = specConstrThreshold dflags,
781           sc_count       = specConstrCount     dflags,
782           sc_recursive   = specConstrRecursive dflags,
783           sc_force       = False,
784           sc_subst       = emptySubst,
785           sc_how_bound   = emptyVarEnv,
786           sc_vals        = emptyVarEnv,
787           sc_annotations = anns }
788
789 data HowBound = RecFun  -- These are the recursive functions for which
790                         -- we seek interesting call patterns
791
792               | RecArg  -- These are those functions' arguments, or their sub-components;
793                         -- we gather occurrence information for these
794
795 instance Outputable HowBound where
796   ppr RecFun = text "RecFun"
797   ppr RecArg = text "RecArg"
798
799 scForce :: ScEnv -> Bool -> ScEnv
800 scForce env b = env { sc_force = b }
801
802 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
803 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
804
805 scSubstId :: ScEnv -> Id -> CoreExpr
806 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
807
808 scSubstTy :: ScEnv -> Type -> Type
809 scSubstTy env ty = substTy (sc_subst env) ty
810
811 scSubstCo :: ScEnv -> Coercion -> Coercion
812 scSubstCo env co = substCo (sc_subst env) co
813
814 zapScSubst :: ScEnv -> ScEnv
815 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
816
817 extendScInScope :: ScEnv -> [Var] -> ScEnv
818         -- Bring the quantified variables into scope
819 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
820
821         -- Extend the substitution
822 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
823 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
824
825 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
826 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
827
828 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
829 extendHowBound env bndrs how_bound
830   = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
831                             [(bndr,how_bound) | bndr <- bndrs] }
832
833 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
834 extendBndrsWith how_bound env bndrs
835   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
836   where
837     (subst', bndrs') = substBndrs (sc_subst env) bndrs
838     hb_env' = sc_how_bound env `extendVarEnvList`
839                     [(bndr,how_bound) | bndr <- bndrs']
840
841 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
842 extendBndrWith how_bound env bndr
843   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
844   where
845     (subst', bndr') = substBndr (sc_subst env) bndr
846     hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
847
848 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
849 extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
850                       where
851                         (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
852
853 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
854 extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
855                       where
856                         (subst', bndr') = substBndr (sc_subst env) bndr
857
858 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
859 extendValEnv env _  Nothing   = env
860 extendValEnv env id (Just cv) 
861  | valueIsWorkFree cv      -- Don't duplicate work!!  Trac #7865
862  = env { sc_vals = extendVarEnv (sc_vals env) id cv }
863 extendValEnv env _ _ = env
864
865 extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
866 -- When we encounter
867 --      case scrut of b
868 --          C x y -> ...
869 -- we want to bind b, to (C x y)
870 -- NB1: Extends only the sc_vals part of the envt
871 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
872 --      they are potentially made alive by the [b -> C x y] binding
873 extendCaseBndrs env scrut case_bndr con alt_bndrs
874    = (env2, alt_bndrs')
875  where
876    live_case_bndr = not (isDeadBinder case_bndr)
877    env1 | Var v <- scrut = extendValEnv env v cval
878         | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]
879    env2 | live_case_bndr = extendValEnv env1 case_bndr cval
880         | otherwise      = env1
881
882    alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
883               = map zap alt_bndrs
884               | otherwise
885               = alt_bndrs
886
887    cval = case con of
888                 DEFAULT    -> Nothing
889                 LitAlt {}  -> Just (ConVal con [])
890                 DataAlt {} -> Just (ConVal con vanilla_args)
891                       where
892                         vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
893                                        varsToCoreExprs alt_bndrs
894
895    zap v | isTyVar v = v                -- See NB2 above
896          | otherwise = zapIdOccInfo v
897
898
899 decreaseSpecCount :: ScEnv -> Int -> ScEnv
900 -- See Note [Avoiding exponential blowup]
901 decreaseSpecCount env n_specs
902   = env { sc_count = case sc_count env of
903                        Nothing -> Nothing
904                        Just n  -> Just (n `div` (n_specs + 1)) }
905         -- The "+1" takes account of the original function;
906         -- See Note [Avoiding exponential blowup]
907
908 ---------------------------------------------------
909 -- See Note [SpecConstrAnnotation]
910 ignoreType    :: ScEnv -> Type   -> Bool
911 ignoreDataCon  :: ScEnv -> DataCon -> Bool
912 forceSpecBndr :: ScEnv -> Var    -> Bool
913 #ifndef GHCI
914 ignoreType    _ _  = False
915 ignoreDataCon  _ _ = False
916 forceSpecBndr _ _  = False
917
918 #else /* GHCI */
919
920 ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
921
922 ignoreType env ty
923   = case tyConAppTyCon_maybe ty of
924       Just tycon -> ignoreTyCon env tycon
925       _          -> False
926
927 ignoreTyCon :: ScEnv -> TyCon -> Bool
928 ignoreTyCon env tycon
929   = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
930
931 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
932
933 forceSpecFunTy :: ScEnv -> Type -> Bool
934 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
935
936 forceSpecArgTy :: ScEnv -> Type -> Bool
937 forceSpecArgTy env ty
938   | Just ty' <- coreView ty = forceSpecArgTy env ty'
939
940 forceSpecArgTy env ty
941   | Just (tycon, tys) <- splitTyConApp_maybe ty
942   , tycon /= funTyCon
943       = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
944         || any (forceSpecArgTy env) tys
945
946 forceSpecArgTy _ _ = False
947 #endif /* GHCI */
948 \end{code}
949
950 Note [Add scrutinee to ValueEnv too]
951 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
952 Consider this:
953    case x of y
954      (a,b) -> case b of c
955                 I# v -> ...(f y)...
956 By the time we get to the call (f y), the ValueEnv
957 will have a binding for y, and for c
958     y -> (a,b)
959     c -> I# v
960 BUT that's not enough!  Looking at the call (f y) we
961 see that y is pair (a,b), but we also need to know what 'b' is.
962 So in extendCaseBndrs we must *also* add the binding
963    b -> I# v
964 else we lose a useful specialisation for f.  This is necessary even
965 though the simplifier has systematically replaced uses of 'x' with 'y'
966 and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came
967 from outside the case.  See Trac #4908 for the live example.
968
969 Note [Avoiding exponential blowup]
970 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
971 The sc_count field of the ScEnv says how many times we are prepared to
972 duplicate a single function.  But we must take care with recursive
973 specialisations.  Consider
974
975         let $j1 = let $j2 = let $j3 = ...
976                             in
977                             ...$j3...
978                   in
979                   ...$j2...
980         in
981         ...$j1...
982
983 If we specialise $j1 then in each specialisation (as well as the original)
984 we can specialise $j2, and similarly $j3.  Even if we make just *one*
985 specialisation of each, because we also have the original we'll get 2^n
986 copies of $j3, which is not good.
987
988 So when recursively specialising we divide the sc_count by the number of
989 copies we are making at this level, including the original.
990
991
992 %************************************************************************
993 %*                                                                      *
994 \subsection{Usage information: flows upwards}
995 %*                                                                      *
996 %************************************************************************
997
998 \begin{code}
999 data ScUsage
1000    = SCU {
1001         scu_calls :: CallEnv,           -- Calls
1002                                         -- The functions are a subset of the
1003                                         --      RecFuns in the ScEnv
1004
1005         scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
1006      }                                  -- The domain is OutIds
1007
1008 type CallEnv = IdEnv [Call]
1009 type Call = (ValueEnv, [CoreArg])
1010         -- The arguments of the call, together with the
1011         -- env giving the constructor bindings at the call site
1012
1013 nullUsage :: ScUsage
1014 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
1015
1016 combineCalls :: CallEnv -> CallEnv -> CallEnv
1017 combineCalls = plusVarEnv_C (++)
1018
1019 combineUsage :: ScUsage -> ScUsage -> ScUsage
1020 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
1021                            scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
1022
1023 combineUsages :: [ScUsage] -> ScUsage
1024 combineUsages [] = nullUsage
1025 combineUsages us = foldr1 combineUsage us
1026
1027 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
1028 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
1029   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
1030      [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
1031
1032 data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
1033             | UnkOcc    -- Used in some unknown way
1034
1035             | ScrutOcc  -- See Note [ScrutOcc]
1036                  (DataConEnv [ArgOcc])   -- How the sub-components are used
1037
1038 type DataConEnv a = UniqFM a     -- Keyed by DataCon
1039
1040 {- Note  [ScrutOcc]
1041 ~~~~~~~~~~~~~~~~~~~
1042 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
1043 is *only* taken apart or applied.
1044
1045   Functions, literal: ScrutOcc emptyUFM
1046   Data constructors:  ScrutOcc subs,
1047
1048 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
1049 The domain of the UniqFM is the Unique of the data constructor
1050
1051 The [ArgOcc] is the occurrences of the *pattern-bound* components
1052 of the data structure.  E.g.
1053         data T a = forall b. MkT a b (b->a)
1054 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
1055
1056 -}
1057
1058 instance Outputable ArgOcc where
1059   ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
1060   ppr UnkOcc        = ptext (sLit "unk-occ")
1061   ppr NoOcc         = ptext (sLit "no-occ")
1062
1063 evalScrutOcc :: ArgOcc
1064 evalScrutOcc = ScrutOcc emptyUFM
1065
1066 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
1067 -- that if the thing is scrutinised anywhere then we get to see that
1068 -- in the overall result, even if it's also used in a boxed way
1069 -- This might be too agressive; see Note [Reboxing] Alternative 3
1070 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
1071 combineOcc NoOcc         occ           = occ
1072 combineOcc occ           NoOcc         = occ
1073 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
1074 combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys
1075 combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs
1076 combineOcc UnkOcc        UnkOcc        = UnkOcc
1077
1078 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
1079 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
1080
1081 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
1082 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
1083 -- is a variable, and an interesting variable
1084 setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ
1085 setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ
1086 setScrutOcc env usg (Var v)    occ
1087   | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
1088   | otherwise                           = usg
1089 setScrutOcc _env usg _other _occ        -- Catch-all
1090   = usg
1091 \end{code}
1092
1093 %************************************************************************
1094 %*                                                                      *
1095 \subsection{The main recursive function}
1096 %*                                                                      *
1097 %************************************************************************
1098
1099 The main recursive function gathers up usage information, and
1100 creates specialised versions of functions.
1101
1102 \begin{code}
1103 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
1104         -- The unique supply is needed when we invent
1105         -- a new name for the specialised function and its args
1106
1107 scExpr env e = scExpr' env e
1108
1109
1110 scExpr' env (Var v)      = case scSubstId env v of
1111                             Var v' -> return (mkVarUsage env v' [], Var v')
1112                             e'     -> scExpr (zapScSubst env) e'
1113
1114 scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))
1115 scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
1116 scExpr' _   e@(Lit {})   = return (nullUsage, e)
1117 scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e
1118                               return (usg, Tick t e')
1119 scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e
1120                               return (usg, Cast e' (scSubstCo env co))
1121 scExpr' env e@(App _ _)  = scApp env (collectArgs e)
1122 scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b
1123                               (usg, e') <- scExpr env' e
1124                               return (usg, Lam b' e')
1125
1126 scExpr' env (Case scrut b ty alts)
1127   = do  { (scrut_usg, scrut') <- scExpr env scrut
1128         ; case isValue (sc_vals env) scrut' of
1129                 Just (ConVal con args) -> sc_con_app con args scrut'
1130                 _other                 -> sc_vanilla scrut_usg scrut'
1131         }
1132   where
1133     sc_con_app con args scrut'  -- Known constructor; simplify
1134      = do { let (_, bs, rhs) = findAlt con alts
1135                                   `orElse` (DEFAULT, [], mkImpossibleExpr ty)
1136                 alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
1137           ; scExpr alt_env' rhs }
1138
1139     sc_vanilla scrut_usg scrut' -- Normal case
1140      = do { let (alt_env,b') = extendBndrWith RecArg env b
1141                         -- Record RecArg for the components
1142
1143           ; (alt_usgs, alt_occs, alts')
1144                 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
1145
1146           ; let scrut_occ  = foldr combineOcc NoOcc alt_occs
1147                 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
1148                 -- The combined usage of the scrutinee is given
1149                 -- by scrut_occ, which is passed to scScrut, which
1150                 -- in turn treats a bare-variable scrutinee specially
1151
1152           ; return (foldr combineUsage scrut_usg' alt_usgs,
1153                     Case scrut' b' (scSubstTy env ty) alts') }
1154
1155     sc_alt env scrut' b' (con,bs,rhs)
1156      = do { let (env1, bs1) = extendBndrsWith RecArg env bs
1157                 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
1158           ; (usg, rhs') <- scExpr env2 rhs
1159           ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
1160                 scrut_occ = case con of
1161                                DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
1162                                _          -> ScrutOcc emptyUFM
1163           ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
1164
1165 scExpr' env (Let (NonRec bndr rhs) body)
1166   | isTyVar bndr        -- Type-lets may be created by doBeta
1167   = scExpr' (extendScSubst env bndr rhs) body
1168
1169   | otherwise
1170   = do  { let (body_env, bndr') = extendBndr env bndr
1171         ; (rhs_usg, rhs_info)  <- scRecRhs env (bndr',rhs)
1172
1173         ; let body_env2         = extendHowBound body_env [bndr'] RecFun
1174                                    -- Note [Local let bindings]
1175               RI _ rhs' _ _ _   = rhs_info
1176               body_env3         = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
1177
1178         ; (body_usg, body') <- scExpr body_env3 body
1179
1180           -- NB: For non-recursive bindings we inherit sc_force flag from
1181           -- the parent function (see Note [Forcing specialisation])
1182         ; (spec_usg, specs) <- specialise env
1183                                           (scu_calls body_usg)
1184                                           rhs_info
1185                                           (SI [] 0 (Just rhs_usg))
1186
1187         ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1188                     `combineUsage` rhs_usg `combineUsage` spec_usg,
1189                   mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1190         }
1191
1192
1193 -- A *local* recursive group: see Note [Local recursive groups]
1194 scExpr' env (Let (Rec prs) body)
1195   = do  { let (bndrs,rhss)      = unzip prs
1196               (rhs_env1,bndrs') = extendRecBndrs env bndrs
1197               rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun
1198               force_spec        = any (forceSpecBndr env) bndrs'
1199                 -- Note [Forcing specialisation]
1200
1201         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1202         ; (body_usg, body')     <- scExpr rhs_env2 body
1203
1204         -- NB: start specLoop from body_usg
1205         ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
1206                                         (scu_calls body_usg) rhs_infos nullUsage
1207                                         [SI [] 0 (Just usg) | usg <- rhs_usgs]
1208                 -- Do not unconditionally generate specialisations from rhs_usgs
1209                 -- Instead use them only if we find an unspecialised call
1210                 -- See Note [Local recursive groups]
1211
1212         ; let rhs_usg = combineUsages rhs_usgs
1213               all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg
1214               bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1215
1216         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1217                   Let bind' body') }
1218 \end{code}
1219
1220 Note [Local let bindings]
1221 ~~~~~~~~~~~~~~~~~~~~~~~~~
1222 It is not uncommon to find this
1223
1224    let $j = \x. <blah> in ...$j True...$j True...
1225
1226 Here $j is an arbitrary let-bound function, but it often comes up for
1227 join points.  We might like to specialise $j for its call patterns.
1228 Notice the difference from a letrec, where we look for call patterns
1229 in the *RHS* of the function.  Here we look for call patterns in the
1230 *body* of the let.
1231
1232 At one point I predicated this on the RHS mentioning the outer
1233 recursive function, but that's not essential and might even be
1234 harmful.  I'm not sure.
1235
1236
1237 \begin{code}
1238 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1239
1240 scApp env (Var fn, args)        -- Function is a variable
1241   = ASSERT( not (null args) )
1242     do  { args_w_usgs <- mapM (scExpr env) args
1243         ; let (arg_usgs, args') = unzip args_w_usgs
1244               arg_usg = combineUsages arg_usgs
1245         ; case scSubstId env fn of
1246             fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1247                         -- Do beta-reduction and try again
1248
1249             Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
1250                                mkApps (Var fn') args')
1251
1252             other_fn' -> return (arg_usg, mkApps other_fn' args') }
1253                 -- NB: doing this ignores any usage info from the substituted
1254                 --     function, but I don't think that matters.  If it does
1255                 --     we can fix it.
1256   where
1257     doBeta :: OutExpr -> [OutExpr] -> OutExpr
1258     -- ToDo: adjust for System IF
1259     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1260     doBeta fn              args         = mkApps fn args
1261
1262 -- The function is almost always a variable, but not always.
1263 -- In particular, if this pass follows float-in,
1264 -- which it may, we can get
1265 --      (let f = ...f... in f) arg1 arg2
1266 scApp env (other_fn, args)
1267   = do  { (fn_usg,   fn')   <- scExpr env other_fn
1268         ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1269         ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1270
1271 ----------------------
1272 mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
1273 mkVarUsage env fn args
1274   = case lookupHowBound env fn of
1275         Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)]
1276                            , scu_occs  = emptyVarEnv }
1277         Just RecArg -> SCU { scu_calls = emptyVarEnv
1278                            , scu_occs  = unitVarEnv fn arg_occ }
1279         Nothing     -> nullUsage
1280   where
1281     -- I rather think we could use UnkOcc all the time
1282     arg_occ | null args = UnkOcc
1283             | otherwise = evalScrutOcc
1284
1285 ----------------------
1286 scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1287 scTopBindEnv env (Rec prs)
1288   = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1289               rhs_env2          = extendHowBound rhs_env1 bndrs RecFun
1290
1291               prs'              = zip bndrs' rhss
1292         ; return (rhs_env2, Rec prs') }
1293   where
1294     (bndrs,rhss) = unzip prs
1295
1296 scTopBindEnv env (NonRec bndr rhs)
1297   = do  { let (env1, bndr') = extendBndr env bndr
1298               env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)
1299         ; return (env2, NonRec bndr' rhs) }
1300
1301 ----------------------
1302 scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
1303
1304 {-
1305 scTopBind _ usage _
1306   | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False
1307   = error "false"
1308 -}
1309  
1310 scTopBind env usage (Rec prs)
1311   | Just threshold <- sc_size env
1312   , not force_spec
1313   , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)
1314                 -- No specialisation
1315   = do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss
1316         ; return (usage `combineUsage` (combineUsages rhs_usgs), Rec (bndrs `zip` rhss')) }
1317   | otherwise   -- Do specialisation
1318   = do  { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) (bndrs `zip` rhss)
1319         -- ; pprTrace "scTopBind" (ppr bndrs $$ ppr (map (lookupVarEnv (scu_calls usage)) bndrs)) (return ())
1320
1321         -- Note [Top-level recursive groups]
1322         ; let (usg,rest) = if   all (not . isExportedId) bndrs
1323                            then -- pprTrace "scTopBind-T" (ppr bndrs $$ ppr (map (fmap (map snd) . lookupVarEnv (scu_calls usage)) bndrs))
1324                                 ( usage
1325                                 , [SI [] 0 (Just us) | us <- rhs_usgs] )
1326                            else ( combineUsages rhs_usgs
1327                                 , [SI [] 0 Nothing   | _  <- rhs_usgs] )
1328
1329         ; (usage', specs) <- specLoop (scForce env force_spec)
1330                                  (scu_calls usg) rhs_infos nullUsage rest
1331
1332         ; return (usage `combineUsage` usage',
1333                   Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1334   where
1335     (bndrs,rhss) = unzip prs
1336     force_spec   = any (forceSpecBndr env) bndrs
1337       -- Note [Forcing specialisation]
1338
1339 scTopBind env usage (NonRec bndr rhs)
1340   = do  { (rhs_usg', rhs') <- scExpr env rhs
1341         ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }
1342
1343 ----------------------
1344 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1345 scRecRhs env (bndr,rhs)
1346   = do  { let (arg_bndrs,body)       = collectBinders rhs
1347               (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1348         ; (body_usg, body')         <- scExpr body_env body
1349         ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'
1350         ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1351                                    arg_bndrs body arg_occs) }
1352                 -- The arg_occs says how the visible,
1353                 -- lambda-bound binders of the RHS are used
1354                 -- (including the TyVar binders)
1355                 -- Two pats are the same if they match both ways
1356
1357 ----------------------
1358 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1359 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1360   = [(id,rhs) | OS _ _ id rhs <- specs] ++
1361               -- First the specialised bindings
1362
1363     [(fn `addIdSpecialisations` rules, new_rhs)]
1364               -- And now the original binding
1365   where
1366     rules = [r | OS _ r _ _ <- specs]
1367
1368 \end{code}
1369
1370
1371 %************************************************************************
1372 %*                                                                      *
1373                 The specialiser itself
1374 %*                                                                      *
1375 %************************************************************************
1376
1377 \begin{code}
1378 data RhsInfo = RI OutId                 -- The binder
1379                   OutExpr               -- The new RHS
1380                   [InVar] InExpr        -- The *original* RHS (\xs.body)
1381                                         --   Note [Specialise original body]
1382                   [ArgOcc]              -- Info on how the xs occur in body
1383
1384 data SpecInfo = SI [OneSpec]            -- The specialisations we have generated
1385
1386                    Int                  -- Length of specs; used for numbering them
1387
1388                    (Maybe ScUsage)      -- Just cs  => we have not yet used calls in the
1389                                         --             from calls in the *original* RHS as
1390                                         --             seeds for new specialisations;
1391                                         --             if you decide to do so, here is the
1392                                         --             RHS usage (which has not yet been
1393                                         --             unleashed)
1394                                         -- Nothing => we have
1395                                         -- See Note [Local recursive groups]
1396
1397         -- One specialisation: Rule plus definition
1398 data OneSpec  = OS CallPat              -- Call pattern that generated this specialisation
1399                    CoreRule             -- Rule connecting original id with the specialisation
1400                    OutId OutExpr        -- Spec id + its rhs
1401
1402
1403 specLoop :: ScEnv
1404          -> CallEnv
1405          -> [RhsInfo]
1406          -> ScUsage -> [SpecInfo]               -- One per binder; acccumulating parameter
1407          -> UniqSM (ScUsage, [SpecInfo])        -- ...ditto...
1408
1409 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1410   = do  { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1411         ; let (new_usg_s, all_specs) = unzip specs_w_usg
1412               new_usg   = combineUsages new_usg_s
1413               new_calls = scu_calls new_usg
1414               all_usg   = usg_so_far `combineUsage` new_usg
1415         ; if isEmptyVarEnv new_calls then
1416                 return (all_usg, all_specs)
1417           else
1418                 specLoop env new_calls rhs_infos all_usg all_specs }
1419
1420 specialise
1421    :: ScEnv
1422    -> CallEnv                           -- Info on calls
1423    -> RhsInfo
1424    -> SpecInfo                          -- Original RHS plus patterns dealt with
1425    -> UniqSM (ScUsage, SpecInfo)        -- New specialised versions and their usage
1426
1427 -- Note: this only generates *specialised* bindings
1428 -- The original binding is added by specInfoBinds
1429 --
1430 -- Note: the rhs here is the optimised version of the original rhs
1431 -- So when we make a specialised copy of the RHS, we're starting
1432 -- from an RHS whose nested functions have been optimised already.
1433
1434 specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
1435                spec_info@(SI specs spec_count mb_unspec)
1436   | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
1437   , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1438   , notNull arg_bndrs           -- Only specialise functions
1439   , Just all_calls <- lookupVarEnv bind_calls fn
1440   = do  { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1441 --      ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1442 --                                      , text "arg_occs" <+> ppr arg_occs
1443 --                                    , text "calls" <+> ppr all_calls
1444 --                                    , text "good pats" <+> ppr pats])  $
1445 --        return ()
1446
1447                 -- Bale out if too many specialisations
1448         ; let n_pats      = length pats
1449               spec_count' = n_pats + spec_count
1450         ; case sc_count env of
1451             Just max | not (sc_force env) && spec_count' > max
1452                 -> if (debugIsOn || opt_PprStyle_Debug)  -- Suppress this scary message for
1453                    then pprTrace "SpecConstr" msg $      -- ordinary users!  Trac #5125
1454                         return (nullUsage, spec_info)
1455                    else return (nullUsage, spec_info)
1456                 where
1457                    msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1458                                     , nest 2 (ptext (sLit "has") <+>
1459                                               speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1460                                               ptext (sLit "but the limit is") <+> int max) ]
1461                               , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1462                               , extra ]
1463                    extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1464                          | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1465
1466             _normal_case -> do {
1467
1468           let spec_env = decreaseSpecCount env n_pats
1469         ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1470                                                  (pats `zip` [spec_count..])
1471                 -- See Note [Specialise original body]
1472
1473         ; let spec_usg = combineUsages spec_usgs
1474               (new_usg, mb_unspec')
1475                   = case mb_unspec of
1476                       Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1477                       _                          -> (spec_usg,                      mb_unspec)
1478
1479         ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1480   | otherwise
1481   = return (nullUsage, spec_info)               -- The boring case
1482
1483
1484 ---------------------
1485 spec_one :: ScEnv
1486          -> OutId       -- Function
1487          -> [InVar]     -- Lambda-binders of RHS; should match patterns
1488          -> InExpr      -- Body of the original function
1489          -> (CallPat, Int)
1490          -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
1491
1492 -- spec_one creates a specialised copy of the function, together
1493 -- with a rule for using it.  I'm very proud of how short this
1494 -- function is, considering what it does :-).
1495
1496 {-
1497   Example
1498
1499      In-scope: a, x::a
1500      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1501           [c::*, v::(b,c) are presumably bound by the (...) part]
1502   ==>
1503      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1504                   (...entire body of f...) [b -> (b,c),
1505                                             y -> ((:) (a,(b,c)) (x,v) hw)]
1506
1507      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
1508                    v::(b,c),
1509                    hw::[(a,(b,c))] .
1510
1511             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1512 -}
1513
1514 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1515   = do  { spec_uniq <- getUniqueUs
1516         ; let spec_env   = extendScSubstList (extendScInScope env qvars)
1517                                              (arg_bndrs `zip` pats)
1518               fn_name    = idName fn
1519               fn_loc     = nameSrcSpan fn_name
1520               fn_occ     = nameOccName fn_name
1521               spec_occ   = mkSpecOcc fn_occ
1522               -- We use fn_occ rather than fn in the rule_name string
1523               -- as we don't want the uniq to end up in the rule, and
1524               -- hence in the ABI, as that can cause spurious ABI
1525               -- changes (#4012).
1526               rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)
1527               spec_name  = mkInternalName spec_uniq spec_occ fn_loc
1528 --      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ 
1529 --        return ()
1530
1531         -- Specialise the body
1532         ; (spec_usg, spec_body) <- scExpr spec_env body
1533
1534 --      ; pprTrace "done spec_one}" (ppr fn) $ 
1535 --        return ()
1536
1537                 -- And build the results
1538         ; let spec_id    = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) 
1539                              -- See Note [Transfer strictness]
1540                              `setIdStrictness` spec_str
1541                              `setIdArity` count isId spec_lam_args
1542               spec_str   = calcSpecStrictness fn spec_lam_args pats
1543                 -- Conditionally use result of new worker-wrapper transform
1544               (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) qvars False body_ty
1545                 -- Usual w/w hack to avoid generating 
1546                 -- a spec_rhs of unlifted type and no args
1547
1548               spec_rhs   = mkLams spec_lam_args spec_body
1549               body_ty    = exprType spec_body
1550               rule_rhs   = mkVarApps (Var spec_id) spec_call_args
1551               inline_act = idInlineActivation fn
1552               rule       = mkRule True {- Auto -} True {- Local -}
1553                                   rule_name inline_act fn_name qvars pats rule_rhs
1554                            -- See Note [Transfer activation]
1555         ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1556
1557 calcSpecStrictness :: Id                     -- The original function
1558                    -> [Var] -> [CoreExpr]    -- Call pattern
1559                    -> StrictSig              -- Strictness of specialised thing
1560 -- See Note [Transfer strictness]
1561 calcSpecStrictness fn qvars pats
1562   = StrictSig (mkTopDmdType spec_dmds topRes)
1563   where
1564     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
1565     StrictSig (DmdType _ dmds _) = idStrictness fn
1566
1567     dmd_env = go emptyVarEnv dmds pats
1568
1569     go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
1570     go env ds (Type {} : pats)     = go env ds pats
1571     go env ds (Coercion {} : pats) = go env ds pats
1572     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats
1573     go env _      _                = env
1574
1575     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
1576     go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
1577     go_one env d e 
1578            | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
1579            , (Var _, args) <- collectArgs e = go env ds args
1580     go_one env _         _ = env
1581 \end{code}
1582
1583 Note [Specialise original body]
1584 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1585 The RhsInfo for a binding keeps the *original* body of the binding.  We
1586 must specialise that, *not* the result of applying specExpr to the RHS
1587 (which is also kept in RhsInfo). Otherwise we end up specialising a
1588 specialised RHS, and that can lead directly to exponential behaviour.
1589
1590 Note [Transfer activation]
1591 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1592   This note is for SpecConstr, but exactly the same thing
1593   happens in the overloading specialiser; see
1594   Note [Auto-specialisation and RULES] in Specialise.
1595
1596 In which phase should the specialise-constructor rules be active?
1597 Originally I made them always-active, but Manuel found that this
1598 defeated some clever user-written rules.  Then I made them active only
1599 in Phase 0; after all, currently, the specConstr transformation is
1600 only run after the simplifier has reached Phase 0, but that meant
1601 that specialisations didn't fire inside wrappers; see test
1602 simplCore/should_compile/spec-inline.
1603
1604 So now I just use the inline-activation of the parent Id, as the
1605 activation for the specialiation RULE, just like the main specialiser;
1606
1607 This in turn means there is no point in specialising NOINLINE things,
1608 so we test for that.
1609
1610 Note [Transfer strictness]
1611 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1612 We must transfer strictness information from the original function to
1613 the specialised one.  Suppose, for example
1614
1615   f has strictness     SS
1616         and a RULE     f (a:as) b = f_spec a as b
1617
1618 Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need
1619 when calling f_spec instead of call-by-value.  And that can result in
1620 unbounded worsening in space (cf the classic foldl vs foldl')
1621
1622 See Trac #3437 for a good example.
1623
1624 The function calcSpecStrictness performs the calculation.
1625
1626
1627 %************************************************************************
1628 %*                                                                      *
1629 \subsection{Argument analysis}
1630 %*                                                                      *
1631 %************************************************************************
1632
1633 This code deals with analysing call-site arguments to see whether
1634 they are constructor applications.
1635
1636 Note [Free type variables of the qvar types]
1637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1638 In a call (f @a x True), that we want to specialise, what variables should
1639 we quantify over.  Clearly over 'a' and 'x', but what about any type variables
1640 free in x's type?  In fact we don't need to worry about them because (f @a)
1641 can only be a well-typed application if its type is compatible with x, so any
1642 variables free in x's type must be free in (f @a), and hence either be gathered
1643 via 'a' itself, or be in scope at f's defn.  Hence we just take
1644   (exprsFreeVars pats).
1645
1646 BUT phantom type synonyms can mess this reasoning up,
1647   eg   x::T b   with  type T b = Int
1648 So we apply expandTypeSynonyms to the bound Ids.
1649 See Trac # 5458.  Yuk.
1650
1651 \begin{code}
1652 type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
1653
1654 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1655         -- Result has no duplicate patterns,
1656         -- nor ones mentioned in done_pats
1657         -- Bool indicates that there was at least one boring pattern
1658 callsToPats env done_specs bndr_occs calls
1659   = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
1660
1661         ; let good_pats :: [(CallPat, ValueEnv)]
1662               good_pats = catMaybes mb_pats
1663               done_pats = [p | OS p _ _ _ <- done_specs]
1664               is_done p = any (samePat p) done_pats
1665               no_recursive = map fst (filterOut (is_too_recursive env) good_pats)
1666
1667         ; return (any isNothing mb_pats,
1668                   filterOut is_done (nubBy samePat no_recursive)) }
1669
1670 is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool
1671     -- Count the number of recursive constructors in a call pattern,
1672     -- filter out if there are more than the maximum.
1673     -- This is only necessary if ForceSpecConstr is in effect:
1674     -- otherwise specConstrCount will cause specialisation to terminate.
1675     -- See Note [Limit recursive specialisation]
1676 is_too_recursive env ((_,exprs), val_env)
1677  = sc_force env && maximum (map go exprs) > sc_recursive env
1678  where
1679   go e
1680    | Just (ConVal (DataAlt dc) args) <- isValue val_env e
1681    , isRecursiveTyCon (dataConTyCon dc)
1682    = 1 + sum (map go args)
1683
1684    |App f a                          <- e
1685    = go f + go a
1686
1687    | otherwise
1688    = 0
1689
1690 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe (CallPat, ValueEnv))
1691         -- The [Var] is the variables to quantify over in the rule
1692         --      Type variables come first, since they may scope
1693         --      over the following term variables
1694         -- The [CoreExpr] are the argument patterns for the rule
1695 callToPats env bndr_occs (con_env, args)
1696   | length args < length bndr_occs      -- Check saturated
1697   = return Nothing
1698   | otherwise
1699   = do  { let in_scope      = substInScope (sc_subst env)
1700         ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
1701         ; let pat_fvs       = varSetElems (exprsFreeVars pats)
1702               in_scope_vars = getInScopeVars in_scope
1703               qvars         = filterOut (`elemVarSet` in_scope_vars) pat_fvs
1704                 -- Quantify over variables that are not in scope
1705                 -- at the call site
1706                 -- See Note [Free type variables of the qvar types]
1707                 -- See Note [Shadowing] at the top
1708
1709               (tvs, ids)    = partition isTyVar qvars
1710               qvars'        = tvs ++ map sanitise ids
1711                 -- Put the type variables first; the type of a term
1712                 -- variable may mention a type variable
1713
1714               sanitise id   = id `setIdType` expandTypeSynonyms (idType id)
1715                 -- See Note [Free type variables of the qvar types]
1716
1717         ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
1718           if interesting
1719           then return (Just ((qvars', pats), con_env))
1720           else return Nothing }
1721
1722     -- argToPat takes an actual argument, and returns an abstracted
1723     -- version, consisting of just the "constructor skeleton" of the
1724     -- argument, with non-constructor sub-expression replaced by new
1725     -- placeholder variables.  For example:
1726     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
1727
1728 argToPat :: ScEnv
1729          -> InScopeSet                  -- What's in scope at the fn defn site
1730          -> ValueEnv                    -- ValueEnv at the call site
1731          -> CoreArg                     -- A call arg (or component thereof)
1732          -> ArgOcc
1733          -> UniqSM (Bool, CoreArg)
1734
1735 -- Returns (interesting, pat),
1736 -- where pat is the pattern derived from the argument
1737 --            interesting=True if the pattern is non-trivial (not a variable or type)
1738 -- E.g.         x:xs         --> (True, x:xs)
1739 --              f xs         --> (False, w)        where w is a fresh wildcard
1740 --              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
1741 --              \x. x+y      --> (True, \x. x+y)
1742 --              lvl7         --> (True, lvl7)      if lvl7 is bound
1743 --                                                 somewhere further out
1744
1745 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1746   = return (False, arg)
1747
1748 argToPat env in_scope val_env (Tick _ arg) arg_occ
1749   = argToPat env in_scope val_env arg arg_occ
1750         -- Note [Notes in call patterns]
1751         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1752         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
1753         -- Perhaps we should not ignore profiling notes, but I'm going to
1754         -- ride roughshod over them all for now.
1755         --- See Note [Notes in RULE matching] in Rules
1756
1757 argToPat env in_scope val_env (Let _ arg) arg_occ
1758   = argToPat env in_scope val_env arg arg_occ
1759         -- See Note [Matching lets] in Rule.lhs
1760         -- Look through let expressions
1761         -- e.g.         f (let v = rhs in (v,w))
1762         -- Here we can specialise for f (v,w)
1763         -- because the rule-matcher will look through the let.
1764
1765 {- Disabled; see Note [Matching cases] in Rule.lhs
1766 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1767   | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs
1768   = argToPat env in_scope val_env rhs arg_occ
1769 -}
1770
1771 argToPat env in_scope val_env (Cast arg co) arg_occ
1772   | isReflCo co     -- Substitution in the SpecConstr itself
1773                     -- can lead to identity coercions
1774   = argToPat env in_scope val_env arg arg_occ
1775   | not (ignoreType env ty2)
1776   = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1777         ; if not interesting then
1778                 wildCardPat ty2
1779           else do
1780         { -- Make a wild-card pattern for the coercion
1781           uniq <- getUniqueUs
1782         ; let co_name = mkSysTvName uniq (fsLit "sg")
1783               co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
1784         ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
1785   where
1786     Pair ty1 ty2 = coercionKind co
1787
1788
1789
1790 {-      Disabling lambda specialisation for now
1791         It's fragile, and the spec_loop can be infinite
1792 argToPat in_scope val_env arg arg_occ
1793   | is_value_lam arg
1794   = return (True, arg)
1795   where
1796     is_value_lam (Lam v e)         -- Spot a value lambda, even if
1797         | isId v       = True      -- it is inside a type lambda
1798         | otherwise    = is_value_lam e
1799     is_value_lam other = False
1800 -}
1801
1802   -- Check for a constructor application
1803   -- NB: this *precedes* the Var case, so that we catch nullary constrs
1804 argToPat env in_scope val_env arg arg_occ
1805   | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
1806   , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
1807   , Just arg_occs <- mb_scrut dc
1808   = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
1809         ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
1810         ; return (True,
1811                   mkConApp dc (ty_args ++ args')) }
1812   where
1813     mb_scrut dc = case arg_occ of
1814                     ScrutOcc bs
1815                            | Just occs <- lookupUFM bs dc
1816                                           -> Just (occs)  -- See Note [Reboxing]
1817                     _other | sc_force env -> Just (repeat UnkOcc)
1818                            | otherwise    -> Nothing
1819
1820   -- Check if the argument is a variable that
1821   --    (a) is used in an interesting way in the body
1822   --    (b) we know what its value is
1823   -- In that case it counts as "interesting"
1824 argToPat env in_scope val_env (Var v) arg_occ
1825   | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1826     is_value,                                                            -- (b)
1827     not (ignoreType env (varType v))
1828   = return (True, Var v)
1829   where
1830     is_value
1831         | isLocalId v = v `elemInScopeSet` in_scope
1832                         && isJust (lookupVarEnv val_env v)
1833                 -- Local variables have values in val_env
1834         | otherwise   = isValueUnfolding (idUnfolding v)
1835                 -- Imports have unfoldings
1836
1837 --      I'm really not sure what this comment means
1838 --      And by not wild-carding we tend to get forall'd
1839 --      variables that are in scope, which in turn can
1840 --      expose the weakness in let-matching
1841 --      See Note [Matching lets] in Rules
1842
1843   -- Check for a variable bound inside the function.
1844   -- Don't make a wild-card, because we may usefully share
1845   --    e.g.  f a = let x = ... in f (x,x)
1846   -- NB: this case follows the lambda and con-app cases!!
1847 -- argToPat _in_scope _val_env (Var v) _arg_occ
1848 --   = return (False, Var v)
1849         -- SLPJ : disabling this to avoid proliferation of versions
1850         -- also works badly when thinking about seeding the loop
1851         -- from the body of the let
1852         --       f x y = letrec g z = ... in g (x,y)
1853         -- We don't want to specialise for that *particular* x,y
1854
1855   -- The default case: make a wild-card
1856   -- We use this for coercions too
1857 argToPat _env _in_scope _val_env arg _arg_occ
1858   = wildCardPat (exprType arg)
1859
1860 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1861 wildCardPat ty
1862   = do { uniq <- getUniqueUs
1863        ; let id = mkSysLocal (fsLit "sc") uniq ty
1864        ; return (False, varToCoreExpr id) }
1865
1866 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1867            -> [CoreArg] -> [ArgOcc]  -- Should be same length
1868            -> UniqSM (Bool, [CoreArg])
1869 argsToPats env in_scope val_env args occs
1870   = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
1871        ; let (interesting_s, args') = unzip stuff
1872        ; return (or interesting_s, args') }
1873 \end{code}
1874
1875
1876 \begin{code}
1877 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1878 isValue _env (Lit lit)
1879   | litIsLifted lit = Nothing
1880   | otherwise       = Just (ConVal (LitAlt lit) [])
1881
1882 isValue env (Var v)
1883   | Just cval <- lookupVarEnv env v
1884   = Just cval  -- You might think we could look in the idUnfolding here
1885                -- but that doesn't take account of which branch of a
1886                -- case we are in, which is the whole point
1887
1888   | not (isLocalId v) && isCheapUnfolding unf
1889   = isValue env (unfoldingTemplate unf)
1890   where
1891     unf = idUnfolding v
1892         -- However we do want to consult the unfolding
1893         -- as well, for let-bound constructors!
1894
1895 isValue env (Lam b e)
1896   | isTyVar b = case isValue env e of
1897                   Just _  -> Just LambdaVal
1898                   Nothing -> Nothing
1899   | otherwise = Just LambdaVal
1900
1901 isValue _env expr       -- Maybe it's a constructor application
1902   | (Var fun, args) <- collectArgs expr
1903   = case isDataConWorkId_maybe fun of
1904
1905         Just con | args `lengthAtLeast` dataConRepArity con
1906                 -- Check saturated; might be > because the
1907                 --                  arity excludes type args
1908                 -> Just (ConVal (DataAlt con) args)
1909
1910         _other | valArgCount args < idArity fun
1911                 -- Under-applied function
1912                -> Just LambdaVal        -- Partial application
1913
1914         _other -> Nothing
1915
1916 isValue _env _expr = Nothing
1917
1918 valueIsWorkFree :: Value -> Bool
1919 valueIsWorkFree LambdaVal       = True
1920 valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
1921
1922 samePat :: CallPat -> CallPat -> Bool
1923 samePat (vs1, as1) (vs2, as2)
1924   = all2 same as1 as2
1925   where
1926     same (Var v1) (Var v2)
1927         | v1 `elem` vs1 = v2 `elem` vs2
1928         | v2 `elem` vs2 = False
1929         | otherwise     = v1 == v2
1930
1931     same (Lit l1)    (Lit l2)    = l1==l2
1932     same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1933
1934     same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
1935     same (Coercion {}) (Coercion {}) = True
1936     same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes
1937     same (Cast e1 _) e2 = same e1 e2
1938     same e1 (Tick _ e2) = same e1 e2
1939     same e1 (Cast e2 _) = same e1 e2
1940
1941     same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1942                  False  -- Let, lambda, case should not occur
1943     bad (Case {}) = True
1944     bad (Let {})  = True
1945     bad (Lam {})  = True
1946     bad _other    = False
1947 \end{code}
1948
1949 Note [Ignore type differences]
1950 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1951 We do not want to generate specialisations where the call patterns
1952 differ only in their type arguments!  Not only is it utterly useless,
1953 but it also means that (with polymorphic recursion) we can generate
1954 an infinite number of specialisations. Example is Data.Sequence.adjustTree,
1955 I think.
1956