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