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