a202ce55fd314fc4928cfee4d6f3c26db75125c2
[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` rhs_usg `combineUsage` spec_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 rhs_usg = combineUsages rhs_usgs
1239               all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg
1240               bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1241
1242         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1243                   Let bind' body') }
1244 \end{code}
1245
1246 Note [Local let bindings]
1247 ~~~~~~~~~~~~~~~~~~~~~~~~~
1248 It is not uncommon to find this
1249
1250    let $j = \x. <blah> in ...$j True...$j True...
1251
1252 Here $j is an arbitrary let-bound function, but it often comes up for
1253 join points.  We might like to specialise $j for its call patterns.
1254 Notice the difference from a letrec, where we look for call patterns
1255 in the *RHS* of the function.  Here we look for call patterns in the
1256 *body* of the let.
1257
1258 At one point I predicated this on the RHS mentioning the outer
1259 recursive function, but that's not essential and might even be
1260 harmful.  I'm not sure.
1261
1262
1263 \begin{code}
1264 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1265
1266 scApp env (Var fn, args)        -- Function is a variable
1267   = ASSERT( not (null args) )
1268     do  { args_w_usgs <- mapM (scExpr env) args
1269         ; let (arg_usgs, args') = unzip args_w_usgs
1270               arg_usg = combineUsages arg_usgs
1271         ; case scSubstId env fn of
1272             fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1273                         -- Do beta-reduction and try again
1274
1275             Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
1276                                mkApps (Var fn') args')
1277
1278             other_fn' -> return (arg_usg, mkApps other_fn' args') }
1279                 -- NB: doing this ignores any usage info from the substituted
1280                 --     function, but I don't think that matters.  If it does
1281                 --     we can fix it.
1282   where
1283     doBeta :: OutExpr -> [OutExpr] -> OutExpr
1284     -- ToDo: adjust for System IF
1285     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1286     doBeta fn              args         = mkApps fn args
1287
1288 -- The function is almost always a variable, but not always.
1289 -- In particular, if this pass follows float-in,
1290 -- which it may, we can get
1291 --      (let f = ...f... in f) arg1 arg2
1292 scApp env (other_fn, args)
1293   = do  { (fn_usg,   fn')   <- scExpr env other_fn
1294         ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1295         ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1296
1297 ----------------------
1298 mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
1299 mkVarUsage env fn args
1300   = case lookupHowBound env fn of
1301         Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]
1302                            , scu_occs  = emptyVarEnv }
1303         Just RecArg -> SCU { scu_calls = emptyVarEnv
1304                            , scu_occs  = unitVarEnv fn arg_occ }
1305         Nothing     -> nullUsage
1306   where
1307     -- I rather think we could use UnkOcc all the time
1308     arg_occ | null args = UnkOcc
1309             | otherwise = evalScrutOcc
1310
1311 ----------------------
1312 scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1313 scTopBindEnv env (Rec prs)
1314   = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1315               rhs_env2          = extendHowBound rhs_env1 bndrs RecFun
1316
1317               prs'              = zip bndrs' rhss
1318         ; return (rhs_env2, Rec prs') }
1319   where
1320     (bndrs,rhss) = unzip prs
1321
1322 scTopBindEnv env (NonRec bndr rhs)
1323   = do  { let (env1, bndr') = extendBndr env bndr
1324               env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)
1325         ; return (env2, NonRec bndr' rhs) }
1326
1327 ----------------------
1328 scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
1329
1330 {-
1331 scTopBind _ usage _
1332   | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False
1333   = error "false"
1334 -}
1335  
1336 scTopBind env usage (Rec prs)
1337   | Just threshold <- sc_size env
1338   , not force_spec
1339   , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)
1340                 -- No specialisation
1341   = do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss
1342         ; return (usage `combineUsage` (combineUsages rhs_usgs), Rec (bndrs `zip` rhss')) }
1343   | otherwise   -- Do specialisation
1344   = do  { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) prs
1345         -- ; pprTrace "scTopBind" (ppr bndrs $$ ppr (map (lookupVarEnv (scu_calls 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                          = ( usage,                  [SI [] 0 (Just us) | us <- rhs_usgs] )
1352
1353         ; (usage', specs) <- specLoop (scForce env force_spec)
1354                                  (scu_calls usg) rhs_infos nullUsage rest
1355
1356         ; return (usage `combineUsage` 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)
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
1421         -- One specialisation: Rule plus definition
1422 data OneSpec  = OS CallPat              -- Call pattern that generated this specialisation
1423                    CoreRule             -- Rule connecting original id with the specialisation
1424                    OutId OutExpr        -- Spec id + its rhs
1425
1426
1427 specLoop :: ScEnv
1428          -> CallEnv
1429          -> [RhsInfo]
1430          -> ScUsage -> [SpecInfo]               -- One per binder; acccumulating parameter
1431          -> UniqSM (ScUsage, [SpecInfo])        -- ...ditto...
1432
1433 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1434   = do  { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1435         ; let (new_usg_s, all_specs) = unzip specs_w_usg
1436               new_usg   = combineUsages new_usg_s
1437               new_calls = scu_calls new_usg
1438               all_usg   = usg_so_far `combineUsage` new_usg
1439         ; if isEmptyVarEnv new_calls then
1440                 return (all_usg, all_specs)
1441           else
1442                 specLoop env new_calls rhs_infos all_usg all_specs }
1443
1444 specialise
1445    :: ScEnv
1446    -> CallEnv                           -- Info on calls
1447    -> RhsInfo
1448    -> SpecInfo                          -- Original RHS plus patterns dealt with
1449    -> UniqSM (ScUsage, SpecInfo)        -- New specialised versions and their usage
1450
1451 -- Note: this only generates *specialised* bindings
1452 -- The original binding is added by specInfoBinds
1453 --
1454 -- Note: the rhs here is the optimised version of the original rhs
1455 -- So when we make a specialised copy of the RHS, we're starting
1456 -- from an RHS whose nested functions have been optimised already.
1457
1458 specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
1459                spec_info@(SI specs spec_count mb_unspec)
1460   | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
1461   , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1462   , notNull arg_bndrs           -- Only specialise functions
1463   , Just all_calls <- lookupVarEnv bind_calls fn
1464   = do  { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1465
1466                 -- Bale out if too many specialisations
1467         ; let n_pats      = length pats
1468               spec_count' = n_pats + spec_count
1469         ; case sc_count env of
1470             Just max | not (sc_force env) && spec_count' > max
1471                 -> if (debugIsOn || opt_PprStyle_Debug)  -- Suppress this scary message for
1472                    then pprTrace "SpecConstr" msg $      -- ordinary users!  Trac #5125
1473                         return (nullUsage, spec_info)
1474                    else return (nullUsage, spec_info)
1475                 where
1476                    msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1477                                     , nest 2 (ptext (sLit "has") <+>
1478                                               speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1479                                               ptext (sLit "but the limit is") <+> int max) ]
1480                               , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1481                               , extra ]
1482                    extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1483                          | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1484
1485             _normal_case -> do {
1486
1487 --        ; if (not (null pats) || isJust mb_unspec) then
1488 --            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1489 --                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)
1490 --                                        , text "arg_occs" <+> ppr arg_occs
1491 --                                        , text "good pats" <+> ppr pats])  $
1492 --               return ()
1493 --          else return ()
1494
1495         ; let spec_env = decreaseSpecCount env n_pats
1496         ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1497                                                  (pats `zip` [spec_count..])
1498                 -- See Note [Specialise original body]
1499
1500         ; let spec_usg = combineUsages spec_usgs
1501
1502               -- If there were any boring calls among the seeds (= all_calls), then those
1503               -- calls will call the un-specialised function.  So we should use the seeds
1504               -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
1505               -- then in new_usg.
1506               (new_usg, mb_unspec')
1507                   = case mb_unspec of
1508                       Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1509                       _                          -> (spec_usg,                      mb_unspec)
1510
1511         ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1512   | otherwise
1513   = return (nullUsage, spec_info)               -- The boring case
1514
1515
1516 ---------------------
1517 spec_one :: ScEnv
1518          -> OutId       -- Function
1519          -> [InVar]     -- Lambda-binders of RHS; should match patterns
1520          -> InExpr      -- Body of the original function
1521          -> (CallPat, Int)
1522          -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
1523
1524 -- spec_one creates a specialised copy of the function, together
1525 -- with a rule for using it.  I'm very proud of how short this
1526 -- function is, considering what it does :-).
1527
1528 {-
1529   Example
1530
1531      In-scope: a, x::a
1532      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1533           [c::*, v::(b,c) are presumably bound by the (...) part]
1534   ==>
1535      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1536                   (...entire body of f...) [b -> (b,c),
1537                                             y -> ((:) (a,(b,c)) (x,v) hw)]
1538
1539      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
1540                    v::(b,c),
1541                    hw::[(a,(b,c))] .
1542
1543             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1544 -}
1545
1546 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1547   = do  { spec_uniq <- getUniqueUs
1548         ; let spec_env   = extendScSubstList (extendScInScope env qvars)
1549                                              (arg_bndrs `zip` pats)
1550               fn_name    = idName fn
1551               fn_loc     = nameSrcSpan fn_name
1552               fn_occ     = nameOccName fn_name
1553               spec_occ   = mkSpecOcc fn_occ
1554               -- We use fn_occ rather than fn in the rule_name string
1555               -- as we don't want the uniq to end up in the rule, and
1556               -- hence in the ABI, as that can cause spurious ABI
1557               -- changes (#4012).
1558               rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)
1559               spec_name  = mkInternalName spec_uniq spec_occ fn_loc
1560 --      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ 
1561 --        return ()
1562
1563         -- Specialise the body
1564         ; (spec_usg, spec_body) <- scExpr spec_env body
1565
1566 --      ; pprTrace "done spec_one}" (ppr fn) $ 
1567 --        return ()
1568
1569                 -- And build the results
1570         ; let spec_id    = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) 
1571                              -- See Note [Transfer strictness]
1572                              `setIdStrictness` spec_str
1573                              `setIdArity` count isId spec_lam_args
1574               spec_str   = calcSpecStrictness fn spec_lam_args pats
1575                 -- Conditionally use result of new worker-wrapper transform
1576               (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) qvars NoOneShotInfo body_ty
1577                 -- Usual w/w hack to avoid generating 
1578                 -- a spec_rhs of unlifted type and no args
1579
1580               spec_rhs   = mkLams spec_lam_args spec_body
1581               body_ty    = exprType spec_body
1582               rule_rhs   = mkVarApps (Var spec_id) spec_call_args
1583               inline_act = idInlineActivation fn
1584               rule       = mkRule True {- Auto -} True {- Local -}
1585                                   rule_name inline_act fn_name qvars pats rule_rhs
1586                            -- See Note [Transfer activation]
1587         ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1588
1589 calcSpecStrictness :: Id                     -- The original function
1590                    -> [Var] -> [CoreExpr]    -- Call pattern
1591                    -> StrictSig              -- Strictness of specialised thing
1592 -- See Note [Transfer strictness]
1593 calcSpecStrictness fn qvars pats
1594   = mkClosedStrictSig spec_dmds topRes
1595   where
1596     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
1597     StrictSig (DmdType _ dmds _) = idStrictness fn
1598
1599     dmd_env = go emptyVarEnv dmds pats
1600
1601     go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
1602     go env ds (Type {} : pats)     = go env ds pats
1603     go env ds (Coercion {} : pats) = go env ds pats
1604     go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats
1605     go env _      _                = env
1606
1607     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
1608     go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
1609     go_one env d e 
1610            | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
1611            , (Var _, args) <- collectArgs e = go env ds args
1612     go_one env _         _ = env
1613 \end{code}
1614
1615 Note [Specialise original body]
1616 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1617 The RhsInfo for a binding keeps the *original* body of the binding.  We
1618 must specialise that, *not* the result of applying specExpr to the RHS
1619 (which is also kept in RhsInfo). Otherwise we end up specialising a
1620 specialised RHS, and that can lead directly to exponential behaviour.
1621
1622 Note [Transfer activation]
1623 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1624   This note is for SpecConstr, but exactly the same thing
1625   happens in the overloading specialiser; see
1626   Note [Auto-specialisation and RULES] in Specialise.
1627
1628 In which phase should the specialise-constructor rules be active?
1629 Originally I made them always-active, but Manuel found that this
1630 defeated some clever user-written rules.  Then I made them active only
1631 in Phase 0; after all, currently, the specConstr transformation is
1632 only run after the simplifier has reached Phase 0, but that meant
1633 that specialisations didn't fire inside wrappers; see test
1634 simplCore/should_compile/spec-inline.
1635
1636 So now I just use the inline-activation of the parent Id, as the
1637 activation for the specialiation RULE, just like the main specialiser;
1638
1639 This in turn means there is no point in specialising NOINLINE things,
1640 so we test for that.
1641
1642 Note [Transfer strictness]
1643 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1644 We must transfer strictness information from the original function to
1645 the specialised one.  Suppose, for example
1646
1647   f has strictness     SS
1648         and a RULE     f (a:as) b = f_spec a as b
1649
1650 Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need
1651 when calling f_spec instead of call-by-value.  And that can result in
1652 unbounded worsening in space (cf the classic foldl vs foldl')
1653
1654 See Trac #3437 for a good example.
1655
1656 The function calcSpecStrictness performs the calculation.
1657
1658
1659 %************************************************************************
1660 %*                                                                      *
1661 \subsection{Argument analysis}
1662 %*                                                                      *
1663 %************************************************************************
1664
1665 This code deals with analysing call-site arguments to see whether
1666 they are constructor applications.
1667
1668 Note [Free type variables of the qvar types]
1669 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1670 In a call (f @a x True), that we want to specialise, what variables should
1671 we quantify over.  Clearly over 'a' and 'x', but what about any type variables
1672 free in x's type?  In fact we don't need to worry about them because (f @a)
1673 can only be a well-typed application if its type is compatible with x, so any
1674 variables free in x's type must be free in (f @a), and hence either be gathered
1675 via 'a' itself, or be in scope at f's defn.  Hence we just take
1676   (exprsFreeVars pats).
1677
1678 BUT phantom type synonyms can mess this reasoning up,
1679   eg   x::T b   with  type T b = Int
1680 So we apply expandTypeSynonyms to the bound Ids.
1681 See Trac # 5458.  Yuk.
1682
1683 \begin{code}
1684 type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
1685
1686 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1687         -- Result has no duplicate patterns,
1688         -- nor ones mentioned in done_pats
1689         -- Bool indicates that there was at least one boring pattern
1690 callsToPats env done_specs bndr_occs calls
1691   = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
1692
1693         ; let good_pats :: [(CallPat, ValueEnv)]
1694               good_pats = catMaybes mb_pats
1695               done_pats = [p | OS p _ _ _ <- done_specs]
1696               is_done p = any (samePat p) done_pats
1697               no_recursive = map fst (filterOut (is_too_recursive env) good_pats)
1698
1699         ; return (any isNothing mb_pats,
1700                   filterOut is_done (nubBy samePat no_recursive)) }
1701
1702 is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool
1703     -- Count the number of recursive constructors in a call pattern,
1704     -- filter out if there are more than the maximum.
1705     -- This is only necessary if ForceSpecConstr is in effect:
1706     -- otherwise specConstrCount will cause specialisation to terminate.
1707     -- See Note [Limit recursive specialisation]
1708 is_too_recursive env ((_,exprs), val_env)
1709  = sc_force env && maximum (map go exprs) > sc_recursive env
1710  where
1711   go e
1712    | Just (ConVal (DataAlt dc) args) <- isValue val_env e
1713    , isRecursiveTyCon (dataConTyCon dc)
1714    = 1 + sum (map go args)
1715
1716    |App f a                          <- e
1717    = go f + go a
1718
1719    | otherwise
1720    = 0
1721
1722 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe (CallPat, ValueEnv))
1723         -- The [Var] is the variables to quantify over in the rule
1724         --      Type variables come first, since they may scope
1725         --      over the following term variables
1726         -- The [CoreExpr] are the argument patterns for the rule
1727 callToPats env bndr_occs (Call _ args con_env)
1728   | length args < length bndr_occs      -- Check saturated
1729   = return Nothing
1730   | otherwise
1731   = do  { let in_scope      = substInScope (sc_subst env)
1732         ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
1733         ; let pat_fvs       = varSetElems (exprsFreeVars pats)
1734               in_scope_vars = getInScopeVars in_scope
1735               qvars         = filterOut (`elemVarSet` in_scope_vars) pat_fvs
1736                 -- Quantify over variables that are not in scope
1737                 -- at the call site
1738                 -- See Note [Free type variables of the qvar types]
1739                 -- See Note [Shadowing] at the top
1740
1741               (tvs, ids)    = partition isTyVar qvars
1742               qvars'        = tvs ++ map sanitise ids
1743                 -- Put the type variables first; the type of a term
1744                 -- variable may mention a type variable
1745
1746               sanitise id   = id `setIdType` expandTypeSynonyms (idType id)
1747                 -- See Note [Free type variables of the qvar types]
1748
1749         ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
1750           if interesting
1751           then return (Just ((qvars', pats), con_env))
1752           else return Nothing }
1753
1754     -- argToPat takes an actual argument, and returns an abstracted
1755     -- version, consisting of just the "constructor skeleton" of the
1756     -- argument, with non-constructor sub-expression replaced by new
1757     -- placeholder variables.  For example:
1758     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
1759
1760 argToPat :: ScEnv
1761          -> InScopeSet                  -- What's in scope at the fn defn site
1762          -> ValueEnv                    -- ValueEnv at the call site
1763          -> CoreArg                     -- A call arg (or component thereof)
1764          -> ArgOcc
1765          -> UniqSM (Bool, CoreArg)
1766
1767 -- Returns (interesting, pat),
1768 -- where pat is the pattern derived from the argument
1769 --            interesting=True if the pattern is non-trivial (not a variable or type)
1770 -- E.g.         x:xs         --> (True, x:xs)
1771 --              f xs         --> (False, w)        where w is a fresh wildcard
1772 --              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
1773 --              \x. x+y      --> (True, \x. x+y)
1774 --              lvl7         --> (True, lvl7)      if lvl7 is bound
1775 --                                                 somewhere further out
1776
1777 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1778   = return (False, arg)
1779
1780 argToPat env in_scope val_env (Tick _ arg) arg_occ
1781   = argToPat env in_scope val_env arg arg_occ
1782         -- Note [Notes in call patterns]
1783         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1784         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
1785         -- Perhaps we should not ignore profiling notes, but I'm going to
1786         -- ride roughshod over them all for now.
1787         --- See Note [Notes in RULE matching] in Rules
1788
1789 argToPat env in_scope val_env (Let _ arg) arg_occ
1790   = argToPat env in_scope val_env arg arg_occ
1791         -- See Note [Matching lets] in Rule.lhs
1792         -- Look through let expressions
1793         -- e.g.         f (let v = rhs in (v,w))
1794         -- Here we can specialise for f (v,w)
1795         -- because the rule-matcher will look through the let.
1796
1797 {- Disabled; see Note [Matching cases] in Rule.lhs
1798 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1799   | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs
1800   = argToPat env in_scope val_env rhs arg_occ
1801 -}
1802
1803 argToPat env in_scope val_env (Cast arg co) arg_occ
1804   | isReflCo co     -- Substitution in the SpecConstr itself
1805                     -- can lead to identity coercions
1806   = argToPat env in_scope val_env arg arg_occ
1807   | not (ignoreType env ty2)
1808   = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1809         ; if not interesting then
1810                 wildCardPat ty2
1811           else do
1812         { -- Make a wild-card pattern for the coercion
1813           uniq <- getUniqueUs
1814         ; let co_name = mkSysTvName uniq (fsLit "sg")
1815               co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
1816         ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
1817   where
1818     Pair ty1 ty2 = coercionKind co
1819
1820
1821
1822 {-      Disabling lambda specialisation for now
1823         It's fragile, and the spec_loop can be infinite
1824 argToPat in_scope val_env arg arg_occ
1825   | is_value_lam arg
1826   = return (True, arg)
1827   where
1828     is_value_lam (Lam v e)         -- Spot a value lambda, even if
1829         | isId v       = True      -- it is inside a type lambda
1830         | otherwise    = is_value_lam e
1831     is_value_lam other = False
1832 -}
1833
1834   -- Check for a constructor application
1835   -- NB: this *precedes* the Var case, so that we catch nullary constrs
1836 argToPat env in_scope val_env arg arg_occ
1837   | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
1838   , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
1839   , Just arg_occs <- mb_scrut dc
1840   = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
1841         ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
1842         ; return (True,
1843                   mkConApp dc (ty_args ++ args')) }
1844   where
1845     mb_scrut dc = case arg_occ of
1846                     ScrutOcc bs
1847                            | Just occs <- lookupUFM bs dc
1848                                           -> Just (occs)  -- See Note [Reboxing]
1849                     _other | sc_force env -> Just (repeat UnkOcc)
1850                            | otherwise    -> Nothing
1851
1852   -- Check if the argument is a variable that
1853   --    (a) is used in an interesting way in the body
1854   --    (b) we know what its value is
1855   -- In that case it counts as "interesting"
1856 argToPat env in_scope val_env (Var v) arg_occ
1857   | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1858     is_value,                                                            -- (b)
1859     not (ignoreType env (varType v))
1860   = return (True, Var v)
1861   where
1862     is_value
1863         | isLocalId v = v `elemInScopeSet` in_scope
1864                         && isJust (lookupVarEnv val_env v)
1865                 -- Local variables have values in val_env
1866         | otherwise   = isValueUnfolding (idUnfolding v)
1867                 -- Imports have unfoldings
1868
1869 --      I'm really not sure what this comment means
1870 --      And by not wild-carding we tend to get forall'd
1871 --      variables that are in scope, which in turn can
1872 --      expose the weakness in let-matching
1873 --      See Note [Matching lets] in Rules
1874
1875   -- Check for a variable bound inside the function.
1876   -- Don't make a wild-card, because we may usefully share
1877   --    e.g.  f a = let x = ... in f (x,x)
1878   -- NB: this case follows the lambda and con-app cases!!
1879 -- argToPat _in_scope _val_env (Var v) _arg_occ
1880 --   = return (False, Var v)
1881         -- SLPJ : disabling this to avoid proliferation of versions
1882         -- also works badly when thinking about seeding the loop
1883         -- from the body of the let
1884         --       f x y = letrec g z = ... in g (x,y)
1885         -- We don't want to specialise for that *particular* x,y
1886
1887   -- The default case: make a wild-card
1888   -- We use this for coercions too
1889 argToPat _env _in_scope _val_env arg _arg_occ
1890   = wildCardPat (exprType arg)
1891
1892 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1893 wildCardPat ty
1894   = do { uniq <- getUniqueUs
1895        ; let id = mkSysLocal (fsLit "sc") uniq ty
1896        ; return (False, varToCoreExpr id) }
1897
1898 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1899            -> [CoreArg] -> [ArgOcc]  -- Should be same length
1900            -> UniqSM (Bool, [CoreArg])
1901 argsToPats env in_scope val_env args occs
1902   = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
1903        ; let (interesting_s, args') = unzip stuff
1904        ; return (or interesting_s, args') }
1905 \end{code}
1906
1907
1908 \begin{code}
1909 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1910 isValue _env (Lit lit)
1911   | litIsLifted lit = Nothing
1912   | otherwise       = Just (ConVal (LitAlt lit) [])
1913
1914 isValue env (Var v)
1915   | Just cval <- lookupVarEnv env v
1916   = Just cval  -- You might think we could look in the idUnfolding here
1917                -- but that doesn't take account of which branch of a
1918                -- case we are in, which is the whole point
1919
1920   | not (isLocalId v) && isCheapUnfolding unf
1921   = isValue env (unfoldingTemplate unf)
1922   where
1923     unf = idUnfolding v
1924         -- However we do want to consult the unfolding
1925         -- as well, for let-bound constructors!
1926
1927 isValue env (Lam b e)
1928   | isTyVar b = case isValue env e of
1929                   Just _  -> Just LambdaVal
1930                   Nothing -> Nothing
1931   | otherwise = Just LambdaVal
1932
1933 isValue _env expr       -- Maybe it's a constructor application
1934   | (Var fun, args) <- collectArgs expr
1935   = case isDataConWorkId_maybe fun of
1936
1937         Just con | args `lengthAtLeast` dataConRepArity con
1938                 -- Check saturated; might be > because the
1939                 --                  arity excludes type args
1940                 -> Just (ConVal (DataAlt con) args)
1941
1942         _other | valArgCount args < idArity fun
1943                 -- Under-applied function
1944                -> Just LambdaVal        -- Partial application
1945
1946         _other -> Nothing
1947
1948 isValue _env _expr = Nothing
1949
1950 valueIsWorkFree :: Value -> Bool
1951 valueIsWorkFree LambdaVal       = True
1952 valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
1953
1954 samePat :: CallPat -> CallPat -> Bool
1955 samePat (vs1, as1) (vs2, as2)
1956   = all2 same as1 as2
1957   where
1958     same (Var v1) (Var v2)
1959         | v1 `elem` vs1 = v2 `elem` vs2
1960         | v2 `elem` vs2 = False
1961         | otherwise     = v1 == v2
1962
1963     same (Lit l1)    (Lit l2)    = l1==l2
1964     same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1965
1966     same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
1967     same (Coercion {}) (Coercion {}) = True
1968     same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes
1969     same (Cast e1 _) e2 = same e1 e2
1970     same e1 (Tick _ e2) = same e1 e2
1971     same e1 (Cast e2 _) = same e1 e2
1972
1973     same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1974                  False  -- Let, lambda, case should not occur
1975     bad (Case {}) = True
1976     bad (Let {})  = True
1977     bad (Lam {})  = True
1978     bad _other    = False
1979 \end{code}
1980
1981 Note [Ignore type differences]
1982 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1983 We do not want to generate specialisations where the call patterns
1984 differ only in their type arguments!  Not only is it utterly useless,
1985 but it also means that (with polymorphic recursion) we can generate
1986 an infinite number of specialisations. Example is Data.Sequence.adjustTree,
1987 I think.
1988