Make Applicative a superclass of Monad
[ghc.git] / compiler / specialise / Specialise.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
5
6 \begin{code}
7 {-# LANGUAGE CPP #-}
8 module Specialise ( specProgram, specUnfolding ) where
9
10 #include "HsVersions.h"
11
12 import Id
13 import TcType hiding( substTy, extendTvSubstList )
14 import Type   hiding( substTy, extendTvSubstList )
15 import Coercion( Coercion )
16 import Module( Module )
17 import CoreMonad
18 import qualified CoreSubst
19 import CoreUnfold
20 import VarSet
21 import VarEnv
22 import CoreSyn
23 import Rules
24 import PprCore          ( pprParendExpr )
25 import CoreUtils        ( exprIsTrivial, applyTypeToArgs )
26 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
27 import UniqSupply
28 import Name
29 import MkId             ( voidArgId, voidPrimId )
30 import Maybes           ( catMaybes, isJust )
31 import BasicTypes
32 import HscTypes
33 import Bag
34 import DynFlags
35 import Util
36 import Outputable
37 import FastString
38 import State
39
40 #if __GLASGOW_HASKELL__ < 709
41 import Control.Applicative (Applicative(..))
42 #endif
43 import Control.Monad
44 import Data.Map (Map)
45 import qualified Data.Map as Map
46 import qualified FiniteMap as Map
47 \end{code}
48
49 %************************************************************************
50 %*                                                                      *
51 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
52 %*                                                                      *
53 %************************************************************************
54
55 These notes describe how we implement specialisation to eliminate
56 overloading.
57
58 The specialisation pass works on Core
59 syntax, complete with all the explicit dictionary application,
60 abstraction and construction as added by the type checker.  The
61 existing type checker remains largely as it is.
62
63 One important thought: the {\em types} passed to an overloaded
64 function, and the {\em dictionaries} passed are mutually redundant.
65 If the same function is applied to the same type(s) then it is sure to
66 be applied to the same dictionary(s)---or rather to the same {\em
67 values}.  (The arguments might look different but they will evaluate
68 to the same value.)
69
70 Second important thought: we know that we can make progress by
71 treating dictionary arguments as static and worth specialising on.  So
72 we can do without binding-time analysis, and instead specialise on
73 dictionary arguments and no others.
74
75 The basic idea
76 ~~~~~~~~~~~~~~
77 Suppose we have
78
79         let f = <f_rhs>
80         in <body>
81
82 and suppose f is overloaded.
83
84 STEP 1: CALL-INSTANCE COLLECTION
85
86 We traverse <body>, accumulating all applications of f to types and
87 dictionaries.
88
89 (Might there be partial applications, to just some of its types and
90 dictionaries?  In principle yes, but in practice the type checker only
91 builds applications of f to all its types and dictionaries, so partial
92 applications could only arise as a result of transformation, and even
93 then I think it's unlikely.  In any case, we simply don't accumulate such
94 partial applications.)
95
96
97 STEP 2: EQUIVALENCES
98
99 So now we have a collection of calls to f:
100         f t1 t2 d1 d2
101         f t3 t4 d3 d4
102         ...
103 Notice that f may take several type arguments.  To avoid ambiguity, we
104 say that f is called at type t1/t2 and t3/t4.
105
106 We take equivalence classes using equality of the *types* (ignoring
107 the dictionary args, which as mentioned previously are redundant).
108
109 STEP 3: SPECIALISATION
110
111 For each equivalence class, choose a representative (f t1 t2 d1 d2),
112 and create a local instance of f, defined thus:
113
114         f@t1/t2 = <f_rhs> t1 t2 d1 d2
115
116 f_rhs presumably has some big lambdas and dictionary lambdas, so lots
117 of simplification will now result.  However we don't actually *do* that
118 simplification.  Rather, we leave it for the simplifier to do.  If we
119 *did* do it, though, we'd get more call instances from the specialised
120 RHS.  We can work out what they are by instantiating the call-instance
121 set from f's RHS with the types t1, t2.
122
123 Add this new id to f's IdInfo, to record that f has a specialised version.
124
125 Before doing any of this, check that f's IdInfo doesn't already
126 tell us about an existing instance of f at the required type/s.
127 (This might happen if specialisation was applied more than once, or
128 it might arise from user SPECIALIZE pragmas.)
129
130 Recursion
131 ~~~~~~~~~
132 Wait a minute!  What if f is recursive?  Then we can't just plug in
133 its right-hand side, can we?
134
135 But it's ok.  The type checker *always* creates non-recursive definitions
136 for overloaded recursive functions.  For example:
137
138         f x = f (x+x)           -- Yes I know its silly
139
140 becomes
141
142         f a (d::Num a) = let p = +.sel a d
143                          in
144                          letrec fl (y::a) = fl (p y y)
145                          in
146                          fl
147
148 We still have recusion for non-overloaded functions which we
149 speciailise, but the recursive call should get specialised to the
150 same recursive version.
151
152
153 Polymorphism 1
154 ~~~~~~~~~~~~~~
155
156 All this is crystal clear when the function is applied to *constant
157 types*; that is, types which have no type variables inside.  But what if
158 it is applied to non-constant types?  Suppose we find a call of f at type
159 t1/t2.  There are two possibilities:
160
161 (a) The free type variables of t1, t2 are in scope at the definition point
162 of f.  In this case there's no problem, we proceed just as before.  A common
163 example is as follows.  Here's the Haskell:
164
165         g y = let f x = x+x
166               in f y + f y
167
168 After typechecking we have
169
170         g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
171                                 in +.sel a d (f a d y) (f a d y)
172
173 Notice that the call to f is at type type "a"; a non-constant type.
174 Both calls to f are at the same type, so we can specialise to give:
175
176         g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
177                                 in +.sel a d (f@a y) (f@a y)
178
179
180 (b) The other case is when the type variables in the instance types
181 are *not* in scope at the definition point of f.  The example we are
182 working with above is a good case.  There are two instances of (+.sel a d),
183 but "a" is not in scope at the definition of +.sel.  Can we do anything?
184 Yes, we can "common them up", a sort of limited common sub-expression deal.
185 This would give:
186
187         g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
188                                     f@a (x::a) = +.sel@a x x
189                                 in +.sel@a (f@a y) (f@a y)
190
191 This can save work, and can't be spotted by the type checker, because
192 the two instances of +.sel weren't originally at the same type.
193
194 Further notes on (b)
195
196 * There are quite a few variations here.  For example, the defn of
197   +.sel could be floated ouside the \y, to attempt to gain laziness.
198   It certainly mustn't be floated outside the \d because the d has to
199   be in scope too.
200
201 * We don't want to inline f_rhs in this case, because
202 that will duplicate code.  Just commoning up the call is the point.
203
204 * Nothing gets added to +.sel's IdInfo.
205
206 * Don't bother unless the equivalence class has more than one item!
207
208 Not clear whether this is all worth it.  It is of course OK to
209 simply discard call-instances when passing a big lambda.
210
211 Polymorphism 2 -- Overloading
212 ~~~~~~~~~~~~~~
213 Consider a function whose most general type is
214
215         f :: forall a b. Ord a => [a] -> b -> b
216
217 There is really no point in making a version of g at Int/Int and another
218 at Int/Bool, because it's only instancing the type variable "a" which
219 buys us any efficiency. Since g is completely polymorphic in b there
220 ain't much point in making separate versions of g for the different
221 b types.
222
223 That suggests that we should identify which of g's type variables
224 are constrained (like "a") and which are unconstrained (like "b").
225 Then when taking equivalence classes in STEP 2, we ignore the type args
226 corresponding to unconstrained type variable.  In STEP 3 we make
227 polymorphic versions.  Thus:
228
229         f@t1/ = /\b -> <f_rhs> t1 b d1 d2
230
231 We do this.
232
233
234 Dictionary floating
235 ~~~~~~~~~~~~~~~~~~~
236 Consider this
237
238         f a (d::Num a) = let g = ...
239                          in
240                          ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
241
242 Here, g is only called at one type, but the dictionary isn't in scope at the
243 definition point for g.  Usually the type checker would build a
244 definition for d1 which enclosed g, but the transformation system
245 might have moved d1's defn inward.  Solution: float dictionary bindings
246 outwards along with call instances.
247
248 Consider
249
250         f x = let g p q = p==q
251                   h r s = (r+s, g r s)
252               in
253               h x x
254
255
256 Before specialisation, leaving out type abstractions we have
257
258         f df x = let g :: Eq a => a -> a -> Bool
259                      g dg p q = == dg p q
260                      h :: Num a => a -> a -> (a, Bool)
261                      h dh r s = let deq = eqFromNum dh
262                                 in (+ dh r s, g deq r s)
263               in
264               h df x x
265
266 After specialising h we get a specialised version of h, like this:
267
268                     h' r s = let deq = eqFromNum df
269                              in (+ df r s, g deq r s)
270
271 But we can't naively make an instance for g from this, because deq is not in scope
272 at the defn of g.  Instead, we have to float out the (new) defn of deq
273 to widen its scope.  Notice that this floating can't be done in advance -- it only
274 shows up when specialisation is done.
275
276 User SPECIALIZE pragmas
277 ~~~~~~~~~~~~~~~~~~~~~~~
278 Specialisation pragmas can be digested by the type checker, and implemented
279 by adding extra definitions along with that of f, in the same way as before
280
281         f@t1/t2 = <f_rhs> t1 t2 d1 d2
282
283 Indeed the pragmas *have* to be dealt with by the type checker, because
284 only it knows how to build the dictionaries d1 and d2!  For example
285
286         g :: Ord a => [a] -> [a]
287         {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
288
289 Here, the specialised version of g is an application of g's rhs to the
290 Ord dictionary for (Tree Int), which only the type checker can conjure
291 up.  There might not even *be* one, if (Tree Int) is not an instance of
292 Ord!  (All the other specialision has suitable dictionaries to hand
293 from actual calls.)
294
295 Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
296 it is buried in a complex (as-yet-un-desugared) binding group.
297 Maybe we should say
298
299         f@t1/t2 = f* t1 t2 d1 d2
300
301 where f* is the Id f with an IdInfo which says "inline me regardless!".
302 Indeed all the specialisation could be done in this way.
303 That in turn means that the simplifier has to be prepared to inline absolutely
304 any in-scope let-bound thing.
305
306
307 Again, the pragma should permit polymorphism in unconstrained variables:
308
309         h :: Ord a => [a] -> b -> b
310         {-# SPECIALIZE h :: [Int] -> b -> b #-}
311
312 We *insist* that all overloaded type variables are specialised to ground types,
313 (and hence there can be no context inside a SPECIALIZE pragma).
314 We *permit* unconstrained type variables to be specialised to
315         - a ground type
316         - or left as a polymorphic type variable
317 but nothing in between.  So
318
319         {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
320
321 is *illegal*.  (It can be handled, but it adds complication, and gains the
322 programmer nothing.)
323
324
325 SPECIALISING INSTANCE DECLARATIONS
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 Consider
328
329         instance Foo a => Foo [a] where
330                 ...
331         {-# SPECIALIZE instance Foo [Int] #-}
332
333 The original instance decl creates a dictionary-function
334 definition:
335
336         dfun.Foo.List :: forall a. Foo a -> Foo [a]
337
338 The SPECIALIZE pragma just makes a specialised copy, just as for
339 ordinary function definitions:
340
341         dfun.Foo.List@Int :: Foo [Int]
342         dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
343
344 The information about what instance of the dfun exist gets added to
345 the dfun's IdInfo in the same way as a user-defined function too.
346
347
348 Automatic instance decl specialisation?
349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 Can instance decls be specialised automatically?  It's tricky.
351 We could collect call-instance information for each dfun, but
352 then when we specialised their bodies we'd get new call-instances
353 for ordinary functions; and when we specialised their bodies, we might get
354 new call-instances of the dfuns, and so on.  This all arises because of
355 the unrestricted mutual recursion between instance decls and value decls.
356
357 Still, there's no actual problem; it just means that we may not do all
358 the specialisation we could theoretically do.
359
360 Furthermore, instance decls are usually exported and used non-locally,
361 so we'll want to compile enough to get those specialisations done.
362
363 Lastly, there's no such thing as a local instance decl, so we can
364 survive solely by spitting out *usage* information, and then reading that
365 back in as a pragma when next compiling the file.  So for now,
366 we only specialise instance decls in response to pragmas.
367
368
369 SPITTING OUT USAGE INFORMATION
370 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
371
372 To spit out usage information we need to traverse the code collecting
373 call-instance information for all imported (non-prelude?) functions
374 and data types. Then we equivalence-class it and spit it out.
375
376 This is done at the top-level when all the call instances which escape
377 must be for imported functions and data types.
378
379 *** Not currently done ***
380
381
382 Partial specialisation by pragmas
383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384 What about partial specialisation:
385
386         k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
387         {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
388
389 or even
390
391         {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
392
393 Seems quite reasonable.  Similar things could be done with instance decls:
394
395         instance (Foo a, Foo b) => Foo (a,b) where
396                 ...
397         {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
398         {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
399
400 Ho hum.  Things are complex enough without this.  I pass.
401
402
403 Requirements for the simplifer
404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
405 The simplifier has to be able to take advantage of the specialisation.
406
407 * When the simplifier finds an application of a polymorphic f, it looks in
408 f's IdInfo in case there is a suitable instance to call instead.  This converts
409
410         f t1 t2 d1 d2   ===>   f_t1_t2
411
412 Note that the dictionaries get eaten up too!
413
414 * Dictionary selection operations on constant dictionaries must be
415   short-circuited:
416
417         +.sel Int d     ===>  +Int
418
419 The obvious way to do this is in the same way as other specialised
420 calls: +.sel has inside it some IdInfo which tells that if it's applied
421 to the type Int then it should eat a dictionary and transform to +Int.
422
423 In short, dictionary selectors need IdInfo inside them for constant
424 methods.
425
426 * Exactly the same applies if a superclass dictionary is being
427   extracted:
428
429         Eq.sel Int d   ===>   dEqInt
430
431 * Something similar applies to dictionary construction too.  Suppose
432 dfun.Eq.List is the function taking a dictionary for (Eq a) to
433 one for (Eq [a]).  Then we want
434
435         dfun.Eq.List Int d      ===> dEq.List_Int
436
437 Where does the Eq [Int] dictionary come from?  It is built in
438 response to a SPECIALIZE pragma on the Eq [a] instance decl.
439
440 In short, dfun Ids need IdInfo with a specialisation for each
441 constant instance of their instance declaration.
442
443 All this uses a single mechanism: the SpecEnv inside an Id
444
445
446 What does the specialisation IdInfo look like?
447 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
448
449 The SpecEnv of an Id maps a list of types (the template) to an expression
450
451         [Type]  |->  Expr
452
453 For example, if f has this SpecInfo:
454
455         [Int, a]  ->  \d:Ord Int. f' a
456
457 it means that we can replace the call
458
459         f Int t  ===>  (\d. f' t)
460
461 This chucks one dictionary away and proceeds with the
462 specialised version of f, namely f'.
463
464
465 What can't be done this way?
466 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
467 There is no way, post-typechecker, to get a dictionary for (say)
468 Eq a from a dictionary for Eq [a].  So if we find
469
470         ==.sel [t] d
471
472 we can't transform to
473
474         eqList (==.sel t d')
475
476 where
477         eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
478
479 Of course, we currently have no way to automatically derive
480 eqList, nor to connect it to the Eq [a] instance decl, but you
481 can imagine that it might somehow be possible.  Taking advantage
482 of this is permanently ruled out.
483
484 Still, this is no great hardship, because we intend to eliminate
485 overloading altogether anyway!
486
487 A note about non-tyvar dictionaries
488 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
489 Some Ids have types like
490
491         forall a,b,c. Eq a -> Ord [a] -> tau
492
493 This seems curious at first, because we usually only have dictionary
494 args whose types are of the form (C a) where a is a type variable.
495 But this doesn't hold for the functions arising from instance decls,
496 which sometimes get arguments with types of form (C (T a)) for some
497 type constructor T.
498
499 Should we specialise wrt this compound-type dictionary?  We used to say
500 "no", saying:
501         "This is a heuristic judgement, as indeed is the fact that we
502         specialise wrt only dictionaries.  We choose *not* to specialise
503         wrt compound dictionaries because at the moment the only place
504         they show up is in instance decls, where they are simply plugged
505         into a returned dictionary.  So nothing is gained by specialising
506         wrt them."
507
508 But it is simpler and more uniform to specialise wrt these dicts too;
509 and in future GHC is likely to support full fledged type signatures
510 like
511         f :: Eq [(a,b)] => ...
512
513
514 %************************************************************************
515 %*                                                                      *
516 \subsubsection{The new specialiser}
517 %*                                                                      *
518 %************************************************************************
519
520 Our basic game plan is this.  For let(rec) bound function
521         f :: (C a, D c) => (a,b,c,d) -> Bool
522
523 * Find any specialised calls of f, (f ts ds), where
524   ts are the type arguments t1 .. t4, and
525   ds are the dictionary arguments d1 .. d2.
526
527 * Add a new definition for f1 (say):
528
529         f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
530
531   Note that we abstract over the unconstrained type arguments.
532
533 * Add the mapping
534
535         [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
536
537   to the specialisations of f.  This will be used by the
538   simplifier to replace calls
539                 (f t1 t2 t3 t4) da db
540   by
541                 (\d1 d1 -> f1 t2 t4) da db
542
543   All the stuff about how many dictionaries to discard, and what types
544   to apply the specialised function to, are handled by the fact that the
545   SpecEnv contains a template for the result of the specialisation.
546
547 We don't build *partial* specialisations for f.  For example:
548
549   f :: Eq a => a -> a -> Bool
550   {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
551
552 Here, little is gained by making a specialised copy of f.
553 There's a distinct danger that the specialised version would
554 first build a dictionary for (Eq b, Eq c), and then select the (==)
555 method from it!  Even if it didn't, not a great deal is saved.
556
557 We do, however, generate polymorphic, but not overloaded, specialisations:
558
559   f :: Eq a => [a] -> b -> b -> b
560   {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
561
562 Hence, the invariant is this:
563
564         *** no specialised version is overloaded ***
565
566
567 %************************************************************************
568 %*                                                                      *
569 \subsubsection{The exported function}
570 %*                                                                      *
571 %************************************************************************
572
573 \begin{code}
574 specProgram :: ModGuts -> CoreM ModGuts
575 specProgram guts@(ModGuts { mg_module = this_mod
576                           , mg_rules = local_rules
577                           , mg_binds = binds })
578   = do { dflags <- getDynFlags
579
580              -- Specialise the bindings of this module
581        ; (binds', uds) <- runSpecM dflags (go binds)
582
583              -- Specialise imported functions
584        ; hpt_rules <- getRuleBase
585        ; let rule_base = extendRuleBaseList hpt_rules local_rules
586        ; (new_rules, spec_binds) <- specImports dflags this_mod emptyVarSet rule_base uds
587
588        ; let final_binds | null spec_binds = binds'
589                          | otherwise       = Rec (flattenBinds spec_binds) : binds'
590                    -- Note [Glom the bindings if imported functions are specialised]
591
592        ; return (guts { mg_binds = final_binds
593                       , mg_rules = new_rules ++ local_rules }) }
594   where
595         -- We need to start with a Subst that knows all the things
596         -- that are in scope, so that the substitution engine doesn't
597         -- accidentally re-use a unique that's already in use
598         -- Easiest thing is to do it all at once, as if all the top-level
599         -- decls were mutually recursive
600     top_subst = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $
601                                 bindersOfBinds binds
602                    , se_interesting = emptyVarSet }
603
604     go []           = return ([], emptyUDs)
605     go (bind:binds) = do (binds', uds) <- go binds
606                          (bind', uds') <- specBind top_subst bind uds
607                          return (bind' ++ binds', uds')
608
609 specImports :: DynFlags
610             -> Module
611             -> VarSet           -- Don't specialise these ones
612                                 -- See Note [Avoiding recursive specialisation]
613             -> RuleBase         -- Rules from this module and the home package
614                                 -- (but not external packages, which can change)
615             -> UsageDetails     -- Calls for imported things, and floating bindings
616             -> CoreM ( [CoreRule]   -- New rules
617                      , [CoreBind] ) -- Specialised bindings and floating bindings
618 specImports dflags this_mod done rule_base uds
619   = do { let import_calls = varEnvElts (ud_calls uds)
620        ; (rules, spec_binds) <- go rule_base import_calls
621        ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) }
622   where
623     go _ [] = return ([], [])
624     go rb (CIS fn calls_for_fn : other_calls)
625       = do { (rules1, spec_binds1) <- specImport dflags this_mod done rb fn $
626                                       Map.toList calls_for_fn
627            ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
628            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
629
630 specImport :: DynFlags
631            -> Module
632            -> VarSet                -- Don't specialise these
633                                     -- See Note [Avoiding recursive specialisation]
634            -> RuleBase              -- Rules from this module
635            -> Id -> [CallInfo]      -- Imported function and calls for it
636            -> CoreM ( [CoreRule]    -- New rules
637                     , [CoreBind] )  -- Specialised bindings
638 specImport dflags this_mod done rb fn calls_for_fn
639   | fn `elemVarSet` done
640   = return ([], [])     -- No warning.  This actually happens all the time
641                         -- when specialising a recursive function, because
642                         -- the RHS of the specialised function contains a recursive
643                         -- call to the original function
644
645   | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning
646   = return ([], [])
647
648   | wantSpecImport dflags unfolding
649   , Just rhs <- maybeUnfoldingTemplate unfolding
650   = do {     -- Get rules from the external package state
651              -- We keep doing this in case we "page-fault in"
652              -- more rules as we go along
653        ; hsc_env <- getHscEnv
654        ; eps <- liftIO $ hscEPS hsc_env
655        ; let full_rb = unionRuleBase rb (eps_rule_base eps)
656              rules_for_fn = getRules full_rb fn
657
658        ; (rules1, spec_pairs, uds) <- runSpecM dflags $
659               specCalls (Just this_mod) emptySpecEnv rules_for_fn calls_for_fn fn rhs
660        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
661              -- After the rules kick in we may get recursion, but
662              -- we rely on a global GlomBinds to sort that out later
663              -- See Note [Glom the bindings if imported functions are specialised]
664
665               -- Now specialise any cascaded calls
666        ; (rules2, spec_binds2) <- -- pprTrace "specImport" (ppr fn $$ ppr uds $$ ppr rhs) $
667                                   specImports dflags this_mod (extendVarSet done fn)
668                                                      (extendRuleBaseList rb rules1)
669                                                      uds
670
671        ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
672
673   | otherwise
674   = WARN( True, hang (ptext (sLit "specImport discarding:") <+> ppr fn <+> dcolon <+> ppr (idType fn))
675                    2 (  (text "want:" <+> ppr (wantSpecImport dflags unfolding))
676                      $$ (text "stable:" <+> ppr (isStableUnfolding unfolding))
677                      $$ (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) ) )
678     return ([], [])
679   where
680     unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
681
682 wantSpecImport :: DynFlags -> Unfolding -> Bool
683 -- See Note [Specialise imported INLINABLE things]
684 wantSpecImport dflags unf
685  = case unf of
686      NoUnfolding      -> False
687      OtherCon {}      -> False
688      DFunUnfolding {} -> True
689      CoreUnfolding { uf_src = src, uf_guidance = _guidance }
690        | gopt Opt_SpecialiseAggressively dflags -> True
691        | isStableSource src -> True
692                -- Specialise even INLINE things; it hasn't inlined yet,
693                -- so perhaps it never will.  Moreover it may have calls
694                -- inside it that we want to specialise
695        | otherwise -> False    -- Stable, not INLINE, hence INLINEABLE
696 \end{code}
697
698 Note [Specialise imported INLINABLE things]
699 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
700 What imported functions do we specialise?  The basic set is
701  * DFuns and things with INLINABLE pragmas.
702 but with -fspecialise-aggressively we add
703  * Anything with an unfolding template
704
705 Trac #8874 has a good example of why we want to auto-specialise DFuns.
706
707 We have the -fspecialise-aggressively flag (usually off), because we
708 risk lots of orphan modules from over-vigorous specialisation.
709 However it's not a big deal: anything non-recursive with an
710 unfolding-template will probably have been inlined already.
711
712 Note [Glom the bindings if imported functions are specialised]
713 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
714 Suppose we have an imported, *recursive*, INLINABLE function
715    f :: Eq a => a -> a
716    f = /\a \d x. ...(f a d)...
717 In the module being compiled we have
718    g x = f (x::Int)
719 Now we'll make a specialised function
720    f_spec :: Int -> Int
721    f_spec = \x -> ...(f Int dInt)...
722    {-# RULE  f Int _ = f_spec #-}
723    g = \x. f Int dInt x
724 Note that f_spec doesn't look recursive
725 After rewriting with the RULE, we get
726    f_spec = \x -> ...(f_spec)...
727 BUT since f_spec was non-recursive before it'll *stay* non-recursive.
728 The occurrence analyser never turns a NonRec into a Rec.  So we must
729 make sure that f_spec is recursive.  Easiest thing is to make all
730 the specialisations for imported bindings recursive.
731
732
733 Note [Avoiding recursive specialisation]
734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
735 When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
736 'f's RHS.  So we want to specialise g,h.  But we don't want to
737 specialise f any more!  It's possible that f's RHS might have a
738 recursive yet-more-specialised call, so we'd diverge in that case.
739 And if the call is to the same type, one specialisation is enough.
740 Avoiding this recursive specialisation loop is the reason for the
741 'done' VarSet passed to specImports and specImport.
742
743 %************************************************************************
744 %*                                                                      *
745 \subsubsection{@specExpr@: the main function}
746 %*                                                                      *
747 %************************************************************************
748
749 \begin{code}
750 data SpecEnv 
751   = SE { se_subst :: CoreSubst.Subst
752              -- We carry a substitution down:
753              -- a) we must clone any binding that might float outwards,
754              --    to avoid name clashes
755              -- b) we carry a type substitution to use when analysing
756              --    the RHS of specialised bindings (no type-let!)
757
758
759        , se_interesting :: VarSet 
760              -- Dict Ids that we know something about
761              -- and hence may be worth specialising against
762              -- See Note [Interesting dictionary arguments]
763      }
764
765 emptySpecEnv :: SpecEnv
766 emptySpecEnv = SE { se_subst = CoreSubst.emptySubst, se_interesting = emptyVarSet} 
767
768 specVar :: SpecEnv -> Id -> CoreExpr
769 specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v
770
771 specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
772
773 ---------------- First the easy cases --------------------
774 specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)
775 specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)
776 specExpr env (Var v)       = return (specVar env v, emptyUDs)
777 specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)
778 specExpr env (Cast e co)
779   = do { (e', uds) <- specExpr env e
780        ; return ((Cast e' (substCo env co)), uds) }
781 specExpr env (Tick tickish body)
782   = do { (body', uds) <- specExpr env body
783        ; return (Tick (specTickish env tickish) body', uds) }
784
785 ---------------- Applications might generate a call instance --------------------
786 specExpr env expr@(App {})
787   = go expr []
788   where
789     go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg
790                                (fun', uds_app) <- go fun (arg':args)
791                                return (App fun' arg', uds_arg `plusUDs` uds_app)
792
793     go (Var f)       args = case specVar env f of
794                                 Var f' -> return (Var f', mkCallUDs env f' args)
795                                 e'     -> return (e', emptyUDs) -- I don't expect this!
796     go other         _    = specExpr env other
797
798 ---------------- Lambda/case require dumping of usage details --------------------
799 specExpr env e@(Lam _ _) = do
800     (body', uds) <- specExpr env' body
801     let (free_uds, dumped_dbs) = dumpUDs bndrs' uds
802     return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)
803   where
804     (bndrs, body) = collectBinders e
805     (env', bndrs') = substBndrs env bndrs
806         -- More efficient to collect a group of binders together all at once
807         -- and we don't want to split a lambda group with dumped bindings
808
809 specExpr env (Case scrut case_bndr ty alts)
810   = do { (scrut', scrut_uds) <- specExpr env scrut
811        ; (scrut'', case_bndr', alts', alts_uds)
812              <- specCase env scrut' case_bndr alts
813        ; return (Case scrut'' case_bndr' (substTy env ty) alts'
814                 , scrut_uds `plusUDs` alts_uds) }
815
816 ---------------- Finally, let is the interesting case --------------------
817 specExpr env (Let bind body)
818   = do { -- Clone binders
819          (rhs_env, body_env, bind') <- cloneBindSM env bind
820
821          -- Deal with the body
822        ; (body', body_uds) <- specExpr body_env body
823
824         -- Deal with the bindings
825       ; (binds', uds) <- specBind rhs_env bind' body_uds
826
827         -- All done
828       ; return (foldr Let body' binds', uds) }
829
830 specTickish :: SpecEnv -> Tickish Id -> Tickish Id
831 specTickish env (Breakpoint ix ids)
832   = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]
833   -- drop vars from the list if they have a non-variable substitution.
834   -- should never happen, but it's harmless to drop them anyway.
835 specTickish _ other_tickish = other_tickish
836
837 specCase :: SpecEnv
838          -> CoreExpr            -- Scrutinee, already done
839          -> Id -> [CoreAlt]
840          -> SpecM ( CoreExpr    -- New scrutinee
841                   , Id
842                   , [CoreAlt]
843                   , UsageDetails)
844 specCase env scrut' case_bndr [(con, args, rhs)]
845   | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]
846   , interestingDict env scrut'
847   , not (isDeadBinder case_bndr && null sc_args')
848   = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
849
850        ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')
851                               [(con, args', Var sc_arg')]
852                        | sc_arg' <- sc_args' ]
853
854              -- Extend the substitution for RHS to map the *original* binders
855              -- to their floated verions.  
856              mb_sc_flts :: [Maybe DictId]
857              mb_sc_flts = map (lookupVarEnv clone_env) args'
858              clone_env  = zipVarEnv sc_args' sc_args_flt
859              subst_prs  = (case_bndr, Var case_bndr_flt)
860                         : [ (arg, Var sc_flt)
861                           | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
862              env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs
863                                 , se_interesting = se_interesting env_rhs `extendVarSetList`
864                                                    (case_bndr_flt : sc_args_flt) }
865
866        ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs
867        ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')
868              case_bndr_set = unitVarSet case_bndr_flt
869              sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
870                              | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
871              flt_binds     = scrut_bind : sc_binds
872              (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
873              all_uds = flt_binds `addDictBinds` free_uds
874              alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')
875        ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
876   where
877     (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)
878     sc_args' = filter is_flt_sc_arg args'
879
880     clone_me bndr = do { uniq <- getUniqueM
881                        ; return (mkUserLocal occ uniq ty loc) }
882        where
883          name = idName bndr
884          ty   = idType bndr
885          occ  = nameOccName name
886          loc  = getSrcSpan name
887
888     arg_set = mkVarSet args'
889     is_flt_sc_arg var =  isId var
890                       && not (isDeadBinder var)
891                       && isDictTy var_ty
892                       && not (tyVarsOfType var_ty `intersectsVarSet` arg_set)
893        where
894          var_ty = idType var
895
896
897 specCase env scrut case_bndr alts
898   = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
899        ; return (scrut, case_bndr', alts', uds_alts) }
900   where
901     (env_alt, case_bndr') = substBndr env case_bndr
902     spec_alt (con, args, rhs) = do
903           (rhs', uds) <- specExpr env_rhs rhs
904           let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
905           return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)
906         where
907           (env_rhs, args') = substBndrs env_alt args
908 \end{code}
909
910 Note [Floating dictionaries out of cases]
911 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
912 Consider
913    g = \d. case d of { MkD sc ... -> ...(f sc)... }
914 Naively we can't float d2's binding out of the case expression,
915 because 'sc' is bound by the case, and that in turn means we can't
916 specialise f, which seems a pity.
917
918 So we invert the case, by floating out a binding
919 for 'sc_flt' thus:
920     sc_flt = case d of { MkD sc ... -> sc }
921 Now we can float the call instance for 'f'.  Indeed this is just
922 what'll happen if 'sc' was originally bound with a let binding,
923 but case is more efficient, and necessary with equalities. So it's
924 good to work with both.
925
926 You might think that this won't make any difference, because the
927 call instance will only get nuked by the \d.  BUT if 'g' itself is
928 specialised, then transitively we should be able to specialise f.
929
930 In general, given
931    case e of cb { MkD sc ... -> ...(f sc)... }
932 we transform to
933    let cb_flt = e
934        sc_flt = case cb_flt of { MkD sc ... -> sc }
935    in
936    case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
937
938 The "_flt" things are the floated binds; we use the current substitution
939 to substitute sc -> sc_flt in the RHS
940
941 %************************************************************************
942 %*                                                                      *
943                      Dealing with a binding
944 %*                                                                      *
945 %************************************************************************
946
947 \begin{code}
948 specBind :: SpecEnv                     -- Use this for RHSs
949          -> CoreBind
950          -> UsageDetails                -- Info on how the scope of the binding
951          -> SpecM ([CoreBind],          -- New bindings
952                    UsageDetails)        -- And info to pass upstream
953
954 -- Returned UsageDetails:
955 --    No calls for binders of this bind
956 specBind rhs_env (NonRec fn rhs) body_uds
957   = do { (rhs', rhs_uds) <- specExpr rhs_env rhs
958        ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs
959
960        ; let pairs = spec_defns ++ [(fn', rhs')]
961                         -- fn' mentions the spec_defns in its rules,
962                         -- so put the latter first
963
964              combined_uds = body_uds1 `plusUDs` rhs_uds
965                 -- This way round a call in rhs_uds of a function f
966                 -- at type T will override a call of f at T in body_uds1; and
967                 -- that is good because it'll tend to keep "earlier" calls
968                 -- See Note [Specialisation of dictionary functions]
969
970              (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
971                 -- See Note [From non-recursive to recursive]
972
973              final_binds | isEmptyBag dump_dbs = [NonRec b r | (b,r) <- pairs]
974                          | otherwise = [Rec (flattenDictBinds dump_dbs pairs)]
975
976          ; if float_all then
977              -- Rather than discard the calls mentioning the bound variables
978              -- we float this binding along with the others
979               return ([], free_uds `snocDictBinds` final_binds)
980            else
981              -- No call in final_uds mentions bound variables,
982              -- so we can just leave the binding here
983               return (final_binds, free_uds) }
984
985
986 specBind rhs_env (Rec pairs) body_uds
987        -- Note [Specialising a recursive group]
988   = do { let (bndrs,rhss) = unzip pairs
989        ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss
990        ; let scope_uds = body_uds `plusUDs` rhs_uds
991                        -- Includes binds and calls arising from rhss
992
993        ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs
994
995        ; (bndrs3, spec_defns3, uds3)
996              <- if null spec_defns1  -- Common case: no specialisation
997                 then return (bndrs1, [], uds1)
998                 else do {            -- Specialisation occurred; do it again
999                           (bndrs2, spec_defns2, uds2)
1000                               <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)
1001                         ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }
1002
1003        ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3
1004              bind = Rec (flattenDictBinds dumped_dbs $
1005                          spec_defns3 ++ zip bndrs3 rhss')
1006
1007        ; if float_all then
1008               return ([], final_uds `snocDictBind` bind)
1009            else
1010               return ([bind], final_uds) }
1011
1012
1013 ---------------------------
1014 specDefns :: SpecEnv
1015           -> UsageDetails               -- Info on how it is used in its scope
1016           -> [(Id,CoreExpr)]            -- The things being bound and their un-processed RHS
1017           -> SpecM ([Id],               -- Original Ids with RULES added
1018                     [(Id,CoreExpr)],    -- Extra, specialised bindings
1019                     UsageDetails)       -- Stuff to fling upwards from the specialised versions
1020
1021 -- Specialise a list of bindings (the contents of a Rec), but flowing usages
1022 -- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
1023 -- Then if the input CallDetails has a specialised call for 'g', whose specialisation
1024 -- in turn generates a specialised call for 'f', we catch that in this one sweep.
1025 -- But not vice versa (it's a fixpoint problem).
1026
1027 specDefns _env uds []
1028   = return ([], [], uds)
1029 specDefns env uds ((bndr,rhs):pairs)
1030   = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
1031        ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs
1032        ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
1033
1034 ---------------------------
1035 specDefn :: SpecEnv
1036          -> UsageDetails                -- Info on how it is used in its scope
1037          -> Id -> CoreExpr              -- The thing being bound and its un-processed RHS
1038          -> SpecM (Id,                  -- Original Id with added RULES
1039                    [(Id,CoreExpr)],     -- Extra, specialised bindings
1040                    UsageDetails)        -- Stuff to fling upwards from the specialised versions
1041
1042 specDefn env body_uds fn rhs
1043   = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
1044              rules_for_me = idCoreRules fn
1045        ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me
1046                                                     calls_for_me fn rhs
1047        ; return ( fn `addIdSpecialisations` rules
1048                 , spec_defns
1049                 , body_uds_without_me `plusUDs` spec_uds) }
1050                 -- It's important that the `plusUDs` is this way
1051                 -- round, because body_uds_without_me may bind
1052                 -- dictionaries that are used in calls_for_me passed
1053                 -- to specDefn.  So the dictionary bindings in
1054                 -- spec_uds may mention dictionaries bound in
1055                 -- body_uds_without_me
1056
1057 ---------------------------
1058 specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn
1059                                -- Nothing        =>  specialising local fn
1060           -> SpecEnv
1061           -> [CoreRule]                 -- Existing RULES for the fn
1062           -> [CallInfo]
1063           -> Id -> CoreExpr
1064           -> SpecM ([CoreRule],         -- New RULES for the fn
1065                     [(Id,CoreExpr)],    -- Extra, specialised bindings
1066                     UsageDetails)       -- New usage details from the specialised RHSs
1067
1068 -- This function checks existing rules, and does not create
1069 -- duplicate ones. So the caller does not need to do this filtering.
1070 -- See 'already_covered'
1071
1072 specCalls mb_mod env rules_for_me calls_for_me fn rhs
1073         -- The first case is the interesting one
1074   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
1075   && rhs_ids    `lengthAtLeast` n_dicts -- and enough dict args
1076   && notNull calls_for_me               -- And there are some calls to specialise
1077   && not (isNeverActive (idInlineActivation fn))
1078         -- Don't specialise NOINLINE things
1079         -- See Note [Auto-specialisation and RULES]
1080
1081 --   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
1082 --      See Note [Inline specialisation] for why we do not
1083 --      switch off specialisation for inline functions
1084
1085   = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $
1086     do { stuff <- mapM spec_call calls_for_me
1087        ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff)
1088        ; return (spec_rules, spec_defns, plusUDList spec_uds) }
1089
1090   | otherwise   -- No calls or RHS doesn't fit our preconceptions
1091   = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,
1092           ptext (sLit "Missed specialisation opportunity for")
1093                                  <+> ppr fn $$ _trace_doc )
1094           -- Note [Specialisation shape]
1095     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
1096     return ([], [], emptyUDs)
1097   where
1098     _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
1099                      , ppr rhs_ids, ppr n_dicts
1100                      , ppr (idInlineActivation fn) ]
1101
1102     fn_type            = idType fn
1103     fn_arity           = idArity fn
1104     fn_unf             = realIdUnfolding fn     -- Ignore loop-breaker-ness here
1105     (tyvars, theta, _) = tcSplitSigmaTy fn_type
1106     n_tyvars           = length tyvars
1107     n_dicts            = length theta
1108     inl_prag           = idInlinePragma fn
1109     inl_act            = inlinePragmaActivation inl_prag
1110     is_local           = isLocalId fn
1111
1112         -- Figure out whether the function has an INLINE pragma
1113         -- See Note [Inline specialisations]
1114
1115     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
1116
1117     rhs_dict_ids = take n_dicts rhs_ids
1118     body         = mkLams (drop n_dicts rhs_ids) rhs_body
1119                 -- Glue back on the non-dict lambdas
1120
1121     already_covered :: DynFlags -> [CoreExpr] -> Bool
1122     already_covered dflags args      -- Note [Specialisations already covered]
1123        = isJust (lookupRule dflags 
1124                             (CoreSubst.substInScope (se_subst env), realIdUnfolding)
1125                             (const True) 
1126                             fn args rules_for_me)
1127
1128     mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
1129     mk_ty_args [] poly_tvs
1130       = ASSERT( null poly_tvs ) []
1131     mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)
1132       = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs
1133     mk_ty_args (Just ty : call_ts) poly_tvs
1134       = Type ty : mk_ty_args call_ts poly_tvs
1135     mk_ty_args (Nothing : _) [] = panic "mk_ty_args"
1136
1137     ----------------------------------------------------------
1138         -- Specialise to one particular call pattern
1139     spec_call :: CallInfo                         -- Call instance
1140               -> SpecM (Maybe ((Id,CoreExpr),     -- Specialised definition
1141                                UsageDetails,      -- Usage details from specialised body
1142                                CoreRule))         -- Info for the Id's SpecEnv
1143     spec_call (CallKey call_ts, (call_ds, _))
1144       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
1145
1146         -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
1147         -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
1148
1149         -- Construct the new binding
1150         --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
1151         -- PLUS the usage-details
1152         --      { d1' = dx1; d2' = dx2 }
1153         -- where d1', d2' are cloned versions of d1,d2, with the type substitution
1154         -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
1155         --
1156         -- Note that the substitution is applied to the whole thing.
1157         -- This is convenient, but just slightly fragile.  Notably:
1158         --      * There had better be no name clashes in a/b/c
1159         do { let
1160                 -- poly_tyvars = [b] in the example above
1161                 -- spec_tyvars = [a,c]
1162                 -- ty_args     = [t1,b,t3]
1163                 spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
1164                 env1          = extendTvSubstList env spec_tv_binds
1165                 (rhs_env, poly_tyvars) = substBndrs env1
1166                                             [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
1167
1168              -- Clone rhs_dicts, including instantiating their types
1169            ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids
1170            ; let (rhs_env2, dx_binds, spec_dict_args)
1171                             = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids
1172                  ty_args    = mk_ty_args call_ts poly_tyvars
1173                  rule_args  = ty_args ++ map Var inst_dict_ids
1174                  rule_bndrs = poly_tyvars ++ inst_dict_ids
1175
1176            ; dflags <- getDynFlags
1177            ; if already_covered dflags rule_args then
1178                 return Nothing
1179              else do
1180            {    -- Figure out the type of the specialised function
1181              let body_ty = applyTypeToArgs rhs fn_type rule_args
1182                  (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
1183                    | isUnLiftedType body_ty     -- C.f. WwLib.mkWorkerArgs
1184                    = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])
1185                    | otherwise = (poly_tyvars, poly_tyvars)
1186                  spec_id_ty = mkPiTypes lam_args body_ty
1187
1188            ; spec_f <- newSpecIdSM fn spec_id_ty
1189            ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)
1190            ; let
1191                 -- The rule to put in the function's specialisation is:
1192                 --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
1193                 herald = case mb_mod of
1194                            Nothing        -- Specialising local fn
1195                                -> ptext (sLit "SPEC")
1196                            Just this_mod  -- Specialising imoprted fn
1197                                -> ptext (sLit "SPEC/") <> ppr this_mod
1198
1199                 rule_name = mkFastString $ showSDocDump dflags $
1200                             herald <+> ppr fn <+> hsep (map ppr_call_key_ty call_ts)
1201                 spec_env_rule = mkRule True {- Auto generated -} is_local
1202                                   rule_name
1203                                   inl_act       -- Note [Auto-specialisation and RULES]
1204                                   (idName fn)
1205                                   rule_bndrs
1206                                   rule_args
1207                                   (mkVarApps (Var spec_f) app_args)
1208
1209                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
1210                 final_uds = foldr consDictBind rhs_uds dx_binds
1211
1212                 --------------------------------------
1213                 -- Add a suitable unfolding if the spec_inl_prag says so
1214                 -- See Note [Inline specialisations]
1215                 (spec_inl_prag, spec_unf)
1216                   | not is_local && isStrongLoopBreaker (idOccInfo fn)
1217                   = (neverInlinePragma, noUnfolding)
1218                         -- See Note [Specialising imported functions] in OccurAnal
1219
1220                   | InlinePragma { inl_inline = Inlinable } <- inl_prag
1221                   = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding)
1222
1223                   | otherwise
1224                   = (inl_prag, specUnfolding dflags (se_subst env)
1225                                              poly_tyvars (ty_args ++ spec_dict_args)
1226                                              fn_unf)
1227
1228                 --------------------------------------
1229                 -- Adding arity information just propagates it a bit faster
1230                 --      See Note [Arity decrease] in Simplify
1231                 -- Copy InlinePragma information from the parent Id.
1232                 -- So if f has INLINE[1] so does spec_f
1233                 spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)
1234                                         `setInlinePragma` spec_inl_prag
1235                                         `setIdUnfolding`  spec_unf
1236
1237            ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } }
1238
1239 bindAuxiliaryDicts
1240         :: SpecEnv
1241         -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions
1242         -> [DictId]                 -- A cloned dict-id for each dict arg
1243         -> (SpecEnv,                -- Substitute for all orig_dicts
1244             [CoreBind],             -- Auxiliary dict bindings
1245             [CoreExpr])             -- Witnessing expressions (all trivial)
1246 -- Bind any dictionary arguments to fresh names, to preserve sharing
1247 bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
1248                    orig_dict_ids call_ds inst_dict_ids
1249   = (env', dx_binds, spec_dict_args)
1250   where
1251     (dx_binds, spec_dict_args) = go call_ds inst_dict_ids
1252     env' = env { se_subst = CoreSubst.extendIdSubstList subst (orig_dict_ids `zip` spec_dict_args)
1253                , se_interesting = interesting `unionVarSet` interesting_dicts }
1254
1255     interesting_dicts = mkVarSet [ dx_id | NonRec dx_id dx <- dx_binds
1256                                  , interestingDict env dx ]
1257                   -- See Note [Make the new dictionaries interesting]
1258
1259     go [] _  = ([], [])
1260     go (dx:dxs) (dx_id:dx_ids)
1261       | exprIsTrivial dx = (dx_binds, dx:args)
1262       | otherwise        = (NonRec dx_id dx : dx_binds, Var dx_id : args)
1263       where
1264         (dx_binds, args) = go dxs dx_ids
1265              -- In the first case extend the substitution but not bindings;
1266              -- in the latter extend the bindings but not the substitution.
1267              -- For the former, note that we bind the *original* dict in the substitution,
1268              -- overriding any d->dx_id binding put there by substBndrs
1269     go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)
1270 \end{code}
1271
1272 Note [Make the new dictionaries interesting]
1273 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1274 Important!  We're going to substitute dx_id1 for d
1275 and we want it to look "interesting", else we won't gather *any*
1276 consequential calls. E.g.
1277     f d = ...g d....
1278 If we specialise f for a call (f (dfun dNumInt)), we'll get
1279 a consequent call (g d') with an auxiliary definition
1280     d' = df dNumInt
1281 We want that consequent call to look interesting
1282
1283
1284 Note [From non-recursive to recursive]
1285 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1286 Even in the non-recursive case, if any dict-binds depend on 'fn' we might
1287 have built a recursive knot
1288
1289       f a d x = <blah>
1290       MkUD { ud_binds = d7 = MkD ..f..
1291            , ud_calls = ...(f T d7)... }
1292
1293 The we generate
1294
1295       Rec { fs x = <blah>[T/a, d7/d]
1296             f a d x = <blah>
1297                RULE f T _ = fs
1298             d7 = ...f... }
1299
1300 Here the recursion is only through the RULE.
1301
1302
1303 Note [Specialisation of dictionary functions]
1304 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1305 Here is a nasty example that bit us badly: see Trac #3591
1306
1307      class Eq a => C a
1308      instance Eq [a] => C [a]
1309
1310 ---------------
1311      dfun :: Eq [a] -> C [a]
1312      dfun a d = MkD a d (meth d)
1313
1314      d4 :: Eq [T] = <blah>
1315      d2 ::  C [T] = dfun T d4
1316      d1 :: Eq [T] = $p1 d2
1317      d3 ::  C [T] = dfun T d1
1318
1319 None of these definitions is recursive. What happened was that we
1320 generated a specialisation:
1321
1322      RULE forall d. dfun T d = dT  :: C [T]
1323      dT = (MkD a d (meth d)) [T/a, d1/d]
1324         = MkD T d1 (meth d1)
1325
1326 But now we use the RULE on the RHS of d2, to get
1327
1328     d2 = dT = MkD d1 (meth d1)
1329     d1 = $p1 d2
1330
1331 and now d1 is bottom!  The problem is that when specialising 'dfun' we
1332 should first dump "below" the binding all floated dictionary bindings
1333 that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be
1334 placed below 'dfun', and thus unavailable to it when specialising
1335 'dfun'.  That in turn means that the call (dfun T d1) must be
1336 discarded.  On the other hand, the call (dfun T d4) is fine, assuming
1337 d4 doesn't mention dfun.
1338
1339 But look at this:
1340
1341   class C a where { foo,bar :: [a] -> [a] }
1342
1343   instance C Int where
1344      foo x = r_bar x
1345      bar xs = reverse xs
1346
1347   r_bar :: C a => [a] -> [a]
1348   r_bar xs = bar (xs ++ xs)
1349
1350 That translates to:
1351
1352     r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
1353
1354     Rec { $fCInt :: C Int = MkC foo_help reverse
1355           foo_help (xs::[Int]) = r_bar Int $fCInt xs }
1356
1357 The call (r_bar $fCInt) mentions $fCInt,
1358                         which mentions foo_help,
1359                         which mentions r_bar
1360 But we DO want to specialise r_bar at Int:
1361
1362     Rec { $fCInt :: C Int = MkC foo_help reverse
1363           foo_help (xs::[Int]) = r_bar Int $fCInt xs
1364
1365           r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
1366             RULE r_bar Int _ = r_bar_Int
1367
1368           r_bar_Int xs = bar Int $fCInt (xs ++ xs)
1369            }
1370
1371 Note that, because of its RULE, r_bar joins the recursive
1372 group.  (In this case it'll unravel a short moment later.)
1373
1374
1375 Conclusion: we catch the nasty case using filter_dfuns in
1376 callsForMe. To be honest I'm not 100% certain that this is 100%
1377 right, but it works.  Sigh.
1378
1379
1380 Note [Specialising a recursive group]
1381 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1382 Consider
1383     let rec { f x = ...g x'...
1384             ; g y = ...f y'.... }
1385     in f 'a'
1386 Here we specialise 'f' at Char; but that is very likely to lead to
1387 a specialisation of 'g' at Char.  We must do the latter, else the
1388 whole point of specialisation is lost.
1389
1390 But we do not want to keep iterating to a fixpoint, because in the
1391 presence of polymorphic recursion we might generate an infinite number
1392 of specialisations.
1393
1394 So we use the following heuristic:
1395   * Arrange the rec block in dependency order, so far as possible
1396     (the occurrence analyser already does this)
1397
1398   * Specialise it much like a sequence of lets
1399
1400   * Then go through the block a second time, feeding call-info from
1401     the RHSs back in the bottom, as it were
1402
1403 In effect, the ordering maxmimises the effectiveness of each sweep,
1404 and we do just two sweeps.   This should catch almost every case of
1405 monomorphic recursion -- the exception could be a very knotted-up
1406 recursion with multiple cycles tied up together.
1407
1408 This plan is implemented in the Rec case of specBindItself.
1409
1410 Note [Specialisations already covered]
1411 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1412 We obviously don't want to generate two specialisations for the same
1413 argument pattern.  There are two wrinkles
1414
1415 1. We do the already-covered test in specDefn, not when we generate
1416 the CallInfo in mkCallUDs.  We used to test in the latter place, but
1417 we now iterate the specialiser somewhat, and the Id at the call site
1418 might therefore not have all the RULES that we can see in specDefn
1419
1420 2. What about two specialisations where the second is an *instance*
1421 of the first?  If the more specific one shows up first, we'll generate
1422 specialisations for both.  If the *less* specific one shows up first,
1423 we *don't* currently generate a specialisation for the more specific
1424 one.  (See the call to lookupRule in already_covered.)  Reasons:
1425   (a) lookupRule doesn't say which matches are exact (bad reason)
1426   (b) if the earlier specialisation is user-provided, it's
1427       far from clear that we should auto-specialise further
1428
1429 Note [Auto-specialisation and RULES]
1430 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1431 Consider:
1432    g :: Num a => a -> a
1433    g = ...
1434
1435    f :: (Int -> Int) -> Int
1436    f w = ...
1437    {-# RULE f g = 0 #-}
1438
1439 Suppose that auto-specialisation makes a specialised version of
1440 g::Int->Int That version won't appear in the LHS of the RULE for f.
1441 So if the specialisation rule fires too early, the rule for f may
1442 never fire.
1443
1444 It might be possible to add new rules, to "complete" the rewrite system.
1445 Thus when adding
1446         RULE forall d. g Int d = g_spec
1447 also add
1448         RULE f g_spec = 0
1449
1450 But that's a bit complicated.  For now we ask the programmer's help,
1451 by *copying the INLINE activation pragma* to the auto-specialised
1452 rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
1453 will also not be active until phase 2.  And that's what programmers
1454 should jolly well do anyway, even aside from specialisation, to ensure
1455 that g doesn't inline too early.
1456
1457 This in turn means that the RULE would never fire for a NOINLINE
1458 thing so not much point in generating a specialisation at all.
1459
1460 Note [Specialisation shape]
1461 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1462 We only specialise a function if it has visible top-level lambdas
1463 corresponding to its overloading.  E.g. if
1464         f :: forall a. Eq a => ....
1465 then its body must look like
1466         f = /\a. \d. ...
1467
1468 Reason: when specialising the body for a call (f ty dexp), we want to
1469 substitute dexp for d, and pick up specialised calls in the body of f.
1470
1471 This doesn't always work.  One example I came across was this:
1472         newtype Gen a = MkGen{ unGen :: Int -> a }
1473
1474         choose :: Eq a => a -> Gen a
1475         choose n = MkGen (\r -> n)
1476
1477         oneof = choose (1::Int)
1478
1479 It's a silly exapmle, but we get
1480         choose = /\a. g `cast` co
1481 where choose doesn't have any dict arguments.  Thus far I have not
1482 tried to fix this (wait till there's a real example).
1483
1484 Mind you, then 'choose' will be inlined (since RHS is trivial) so 
1485 it doesn't matter.  This comes up with single-method classes
1486
1487    class C a where { op :: a -> a }
1488    instance C a => C [a] where ....
1489 ==>
1490    $fCList :: C a => C [a]
1491    $fCList = $copList |> (...coercion>...)
1492    ....(uses of $fCList at particular types)...
1493
1494 So we suppress the WARN if the rhs is trivial.
1495
1496 Note [Inline specialisations]
1497 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1498 Here is what we do with the InlinePragma of the original function
1499   * Activation/RuleMatchInfo: both transferred to the
1500                               specialised function
1501   * InlineSpec:
1502        (a) An INLINE pragma is transferred
1503        (b) An INLINABLE pragma is *not* transferred
1504
1505 Why (a): transfer INLINE pragmas? The point of INLINE was precisely to
1506 specialise the function at its call site, and arguably that's not so
1507 important for the specialised copies.  BUT *pragma-directed*
1508 specialisation now takes place in the typechecker/desugarer, with
1509 manually specified INLINEs.  The specialisation here is automatic.
1510 It'd be very odd if a function marked INLINE was specialised (because
1511 of some local use), and then forever after (including importing
1512 modules) the specialised version wasn't INLINEd.  After all, the
1513 programmer said INLINE!
1514
1515 You might wonder why we specialise INLINE functions at all.  After
1516 all they should be inlined, right?  Two reasons:
1517
1518  * Even INLINE functions are sometimes not inlined, when they aren't
1519    applied to interesting arguments.  But perhaps the type arguments
1520    alone are enough to specialise (even though the args are too boring
1521    to trigger inlining), and it's certainly better to call the
1522    specialised version.
1523
1524  * The RHS of an INLINE function might call another overloaded function,
1525    and we'd like to generate a specialised version of that function too.
1526    This actually happens a lot. Consider
1527       replicateM_ :: (Monad m) => Int -> m a -> m ()
1528       {-# INLINABLE replicateM_ #-}
1529       replicateM_ d x ma = ...
1530    The strictness analyser may transform to
1531       replicateM_ :: (Monad m) => Int -> m a -> m ()
1532       {-# INLINE replicateM_ #-}
1533       replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma
1534
1535       $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()
1536       {-# INLINABLE $wreplicateM_ #-}
1537       $wreplicateM_ = ...
1538    Now an importing module has a specialised call to replicateM_, say
1539    (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!
1540    This particular example had a huge effect on the call to replicateM_ 
1541    in nofib/shootout/n-body.
1542
1543 Why (b): discard INLINEABLE pragmas? See Trac #4874 for persuasive examples.
1544 Suppose we have
1545     {-# INLINABLE f #-}
1546     f :: Ord a => [a] -> Int
1547     f xs = letrec f' = ...f'... in f'
1548 Then, when f is specialised and optimised we might get
1549     wgo :: [Int] -> Int#
1550     wgo = ...wgo...
1551     f_spec :: [Int] -> Int
1552     f_spec xs = case wgo xs of { r -> I# r }
1553 and we clearly want to inline f_spec at call sites.  But if we still
1554 have the big, un-optimised of f (albeit specialised) captured in an
1555 INLINABLE pragma for f_spec, we won't get that optimisation.
1556
1557 So we simply drop INLINABLE pragmas when specialising. It's not really
1558 a complete solution; ignoring specalisation for now, INLINABLE functions
1559 don't get properly strictness analysed, for example. But it works well
1560 for examples involving specialisation, which is the dominant use of
1561 INLINABLE.  See Trac #4874.
1562
1563
1564 %************************************************************************
1565 %*                                                                      *
1566 \subsubsection{UsageDetails and suchlike}
1567 %*                                                                      *
1568 %************************************************************************
1569
1570 \begin{code}
1571 data UsageDetails
1572   = MkUD {
1573         ud_binds :: !(Bag DictBind),
1574                         -- Floated dictionary bindings
1575                         -- The order is important;
1576                         -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
1577                         -- (Remember, Bags preserve order in GHC.)
1578
1579         ud_calls :: !CallDetails
1580
1581         -- INVARIANT: suppose bs = bindersOf ud_binds
1582         -- Then 'calls' may *mention* 'bs',
1583         -- but there should be no calls *for* bs
1584     }
1585
1586 instance Outputable UsageDetails where
1587   ppr (MkUD { ud_binds = dbs, ud_calls = calls })
1588         = ptext (sLit "MkUD") <+> braces (sep (punctuate comma
1589                 [ptext (sLit "binds") <+> equals <+> ppr dbs,
1590                  ptext (sLit "calls") <+> equals <+> ppr calls]))
1591
1592 type DictBind = (CoreBind, VarSet)
1593         -- The set is the free vars of the binding
1594         -- both tyvars and dicts
1595
1596 type DictExpr = CoreExpr
1597
1598 emptyUDs :: UsageDetails
1599 emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv }
1600
1601 ------------------------------------------------------------
1602 type CallDetails  = IdEnv CallInfoSet
1603 newtype CallKey   = CallKey [Maybe Type]                        -- Nothing => unconstrained type argument
1604
1605 -- CallInfo uses a Map, thereby ensuring that
1606 -- we record only one call instance for any key
1607 --
1608 -- The list of types and dictionaries is guaranteed to
1609 -- match the type of f
1610 data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet))
1611                         -- Range is dict args and the vars of the whole
1612                         -- call (including tyvars)
1613                         -- [*not* include the main id itself, of course]
1614
1615 type CallInfo = (CallKey, ([DictExpr], VarSet))
1616
1617 instance Outputable CallInfoSet where
1618   ppr (CIS fn map) = hang (ptext (sLit "CIS") <+> ppr fn)
1619                         2 (ppr map)
1620
1621 pprCallInfo :: Id -> CallInfo -> SDoc
1622 pprCallInfo fn (CallKey mb_tys, (dxs, _))
1623   = hang (ppr fn)
1624        2 (fsep (map ppr_call_key_ty mb_tys ++ map pprParendExpr dxs))
1625
1626 ppr_call_key_ty :: Maybe Type -> SDoc
1627 ppr_call_key_ty Nothing   = char '_'
1628 ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty
1629
1630 instance Outputable CallKey where
1631   ppr (CallKey ts) = ppr ts
1632
1633 -- Type isn't an instance of Ord, so that we can control which
1634 -- instance we use.  That's tiresome here.  Oh well
1635 instance Eq CallKey where
1636   k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False }
1637
1638 instance Ord CallKey where
1639   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
1640                 where
1641                   cmp Nothing   Nothing   = EQ
1642                   cmp Nothing   (Just _)  = LT
1643                   cmp (Just _)  Nothing   = GT
1644                   cmp (Just t1) (Just t2) = cmpType t1 t2
1645
1646 unionCalls :: CallDetails -> CallDetails -> CallDetails
1647 unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2
1648
1649 unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
1650 unionCallInfoSet (CIS f calls1) (CIS _ calls2) = CIS f (calls1 `Map.union` calls2)
1651
1652 callDetailsFVs :: CallDetails -> VarSet
1653 callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls
1654
1655 callInfoFVs :: CallInfoSet -> VarSet
1656 callInfoFVs (CIS _ call_info) = Map.foldRight (\(_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info
1657
1658 ------------------------------------------------------------
1659 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
1660 singleCall id tys dicts
1661   = MkUD {ud_binds = emptyBag,
1662           ud_calls = unitVarEnv id $ CIS id $
1663                      Map.singleton (CallKey tys) (dicts, call_fvs) }
1664   where
1665     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
1666     tys_fvs  = tyVarsOfTypes (catMaybes tys)
1667         -- The type args (tys) are guaranteed to be part of the dictionary
1668         -- types, because they are just the constrained types,
1669         -- and the dictionary is therefore sure to be bound
1670         -- inside the binding for any type variables free in the type;
1671         -- hence it's safe to neglect tyvars free in tys when making
1672         -- the free-var set for this call
1673         -- BUT I don't trust this reasoning; play safe and include tys_fvs
1674         --
1675         -- We don't include the 'id' itself.
1676
1677 mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
1678 mkCallUDs env f args
1679   = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])
1680     res
1681   where
1682     res = mkCallUDs' env f args
1683
1684 mkCallUDs' env f args
1685   | not (want_calls_for f)  -- Imported from elsewhere
1686   || null theta             -- Not overloaded
1687   = emptyUDs
1688
1689   |  not (all type_determines_value theta)
1690   || not (spec_tys `lengthIs` n_tyvars)
1691   || not ( dicts   `lengthIs` n_dicts)
1692   || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]
1693   -- See also Note [Specialisations already covered]
1694   = -- pprTrace "mkCallUDs: discarding" _trace_doc
1695     emptyUDs    -- Not overloaded, or no specialisation wanted
1696
1697   | otherwise
1698   = -- pprTrace "mkCallUDs: keeping" _trace_doc
1699     singleCall f spec_tys dicts
1700   where
1701     _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
1702                       , ppr (map (interestingDict env) dicts)]
1703     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
1704     constrained_tyvars = closeOverKinds (tyVarsOfTypes theta)
1705     n_tyvars           = length tyvars
1706     n_dicts            = length theta
1707
1708     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
1709     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
1710
1711     mk_spec_ty tyvar ty
1712         | tyvar `elemVarSet` constrained_tyvars = Just ty
1713         | otherwise                             = Nothing
1714
1715     want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))
1716          -- For imported things, we gather call instances if
1717          -- there is an unfolding that we could in principle specialise
1718          -- We might still decide not to use it (consulting dflags)
1719          -- in specImports
1720          -- Use 'realIdUnfolding' to ignore the loop-breaker flag!
1721
1722     type_determines_value pred    -- See Note [Type determines value]
1723         = case classifyPredType pred of
1724             ClassPred cls _ -> not (isIPClass cls)
1725             TuplePred ps    -> all type_determines_value ps
1726             EqPred {}       -> True
1727             IrredPred {}    -> True   -- Things like (D []) where D is a
1728                                       -- Constraint-ranged family; Trac #7785
1729 \end{code}
1730
1731 Note [Type determines value]
1732 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1733 Only specialise if all overloading is on non-IP *class* params,
1734 because these are the ones whose *type* determines their *value*.  In
1735 parrticular, with implicit params, the type args *don't* say what the
1736 value of the implicit param is!  See Trac #7101
1737
1738 However, consider
1739          type family D (v::*->*) :: Constraint
1740          type instance D [] = ()
1741          f :: D v => v Char -> Int
1742 If we see a call (f "foo"), we'll pass a "dictionary"
1743   () |> (g :: () ~ D [])
1744 and it's good to specialise f at this dictionary.
1745
1746 So the question is: can an implicit parameter "hide inside" a
1747 type-family constraint like (D a).  Well, no.  We don't allow
1748         type instance D Maybe = ?x:Int
1749 Hence the IrredPred case in type_determines_value.
1750 See Trac #7785.
1751
1752 Note [Interesting dictionary arguments]
1753 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1754 Consider this
1755          \a.\d:Eq a.  let f = ... in ...(f d)...
1756 There really is not much point in specialising f wrt the dictionary d,
1757 because the code for the specialised f is not improved at all, because
1758 d is lambda-bound.  We simply get junk specialisations.
1759
1760 What is "interesting"?  Just that it has *some* structure.  But what about
1761 variables?  
1762
1763  * A variable might be imported, in which case its unfolding
1764    will tell us whether it has useful structure
1765
1766  * Local variables are cloned on the way down (to avoid clashes when
1767    we float dictionaries), and cloning drops the unfolding
1768    (cloneIdBndr).  Moreover, we make up some new bindings, and it's a
1769    nuisance to give them unfoldings.  So we keep track of the
1770    "interesting" dictionaries as a VarSet in SpecEnv.
1771    We have to take care to put any new interesting dictionary 
1772    bindings in the set.
1773
1774 We accidentally lost accurate tracking of local variables for a long
1775 time, because cloned variables don't have unfoldings. But makes a 
1776 massive difference in a few cases, eg Trac #5113. For nofib as a 
1777 whole it's only a small win: 2.2% improvement in allocation for ansi,
1778 1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.
1779
1780
1781 \begin{code}
1782 interestingDict :: SpecEnv -> CoreExpr -> Bool
1783 -- A dictionary argument is interesting if it has *some* structure
1784 interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)
1785                             || isDataConWorkId v
1786                             || v `elemVarSet` se_interesting env
1787 interestingDict _ (Type _)                = False
1788 interestingDict _ (Coercion _)            = False
1789 interestingDict env (App fn (Type _))     = interestingDict env fn
1790 interestingDict env (App fn (Coercion _)) = interestingDict env fn
1791 interestingDict env (Tick _ a)            = interestingDict env a
1792 interestingDict env (Cast e _)            = interestingDict env e
1793 interestingDict _ _                       = True
1794 \end{code}
1795
1796 \begin{code}
1797 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
1798 plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
1799         (MkUD {ud_binds = db2, ud_calls = calls2})
1800   = MkUD { ud_binds = db1    `unionBags`   db2
1801          , ud_calls = calls1 `unionCalls`  calls2 }
1802
1803 plusUDList :: [UsageDetails] -> UsageDetails
1804 plusUDList = foldr plusUDs emptyUDs
1805
1806 -----------------------------
1807 _dictBindBndrs :: Bag DictBind -> [Id]
1808 _dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
1809
1810 mkDB :: CoreBind -> DictBind
1811 mkDB bind = (bind, bind_fvs bind)
1812
1813 bind_fvs :: CoreBind -> VarSet
1814 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
1815 bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
1816                            where
1817                              bndrs = map fst prs
1818                              rhs_fvs = unionVarSets (map pair_fvs prs)
1819
1820 pair_fvs :: (Id, CoreExpr) -> VarSet
1821 pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
1822         -- Don't forget variables mentioned in the
1823         -- rules of the bndr.  C.f. OccAnal.addRuleUsage
1824         -- Also tyvars mentioned in its type; they may not appear in the RHS
1825         --      type T a = Int
1826         --      x :: T a = 3
1827
1828 flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
1829 flattenDictBinds dbs pairs
1830   = foldrBag add pairs dbs
1831   where
1832     add (NonRec b r,_) pairs = (b,r) : pairs
1833     add (Rec prs1, _)  pairs = prs1 ++ pairs
1834
1835 snocDictBinds :: UsageDetails -> [CoreBind] -> UsageDetails
1836 -- Add ud_binds to the tail end of the bindings in uds
1837 snocDictBinds uds dbs
1838   = uds { ud_binds = ud_binds uds `unionBags`
1839                      foldr (consBag . mkDB) emptyBag dbs }
1840
1841 consDictBind :: CoreBind -> UsageDetails -> UsageDetails
1842 consDictBind bind uds = uds { ud_binds = mkDB bind `consBag` ud_binds uds }
1843
1844 addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
1845 addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }
1846
1847 snocDictBind :: UsageDetails -> CoreBind -> UsageDetails
1848 snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` mkDB bind }
1849
1850 wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
1851 wrapDictBinds dbs binds
1852   = foldrBag add binds dbs
1853   where
1854     add (bind,_) binds = bind : binds
1855
1856 wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
1857 wrapDictBindsE dbs expr
1858   = foldrBag add expr dbs
1859   where
1860     add (bind,_) expr = Let bind expr
1861
1862 ----------------------
1863 dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
1864 -- Used at a lambda or case binder; just dump anything mentioning the binder
1865 dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1866   | null bndrs = (uds, emptyBag)  -- Common in case alternatives
1867   | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
1868                  (free_uds, dump_dbs)
1869   where
1870     free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
1871     bndr_set = mkVarSet bndrs
1872     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
1873     free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor
1874                  deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be
1875                                                     -- no calls for any of the dicts in dump_dbs
1876
1877 dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
1878 -- Used at a lambda or case binder; just dump anything mentioning the binder
1879 dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1880   = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
1881     (free_uds, dump_dbs, float_all)
1882   where
1883     free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
1884     bndr_set = mkVarSet bndrs
1885     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
1886     free_calls = deleteCallsFor bndrs orig_calls
1887     float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
1888
1889 callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
1890 callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1891   = -- pprTrace ("callsForMe")
1892     --          (vcat [ppr fn,
1893     --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),
1894     --                 text "Orig calls ="   <+> ppr orig_calls,
1895     --                 text "Dep set ="      <+> ppr dep_set,
1896     --                 text "Calls for me =" <+> ppr calls_for_me]) $
1897     (uds_without_me, calls_for_me)
1898   where
1899     uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn }
1900     calls_for_me = case lookupVarEnv orig_calls fn of
1901                         Nothing -> []
1902                         Just (CIS _ calls) -> filter_dfuns (Map.toList calls)
1903
1904     dep_set = foldlBag go (unitVarSet fn) orig_dbs
1905     go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set
1906                         = extendVarSetList dep_set (bindersOf db)
1907                         | otherwise = dep_set
1908
1909         -- Note [Specialisation of dictionary functions]
1910     filter_dfuns | isDFunId fn = filter ok_call
1911                  | otherwise   = \cs -> cs
1912
1913     ok_call (_, (_,fvs)) = not (fvs `intersectsVarSet` dep_set)
1914
1915 ----------------------
1916 splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
1917 -- Returns (free_dbs, dump_dbs, dump_set)
1918 splitDictBinds dbs bndr_set
1919    = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
1920                 -- Important that it's foldl not foldr;
1921                 -- we're accumulating the set of dumped ids in dump_set
1922    where
1923     split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
1924         | dump_idset `intersectsVarSet` fvs     -- Dump it
1925         = (free_dbs, dump_dbs `snocBag` db,
1926            extendVarSetList dump_idset (bindersOf bind))
1927
1928         | otherwise     -- Don't dump it
1929         = (free_dbs `snocBag` db, dump_dbs, dump_idset)
1930
1931
1932 ----------------------
1933 deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
1934 -- Remove calls *mentioning* bs
1935 deleteCallsMentioning bs calls
1936   = mapVarEnv filter_calls calls
1937   where
1938     filter_calls :: CallInfoSet -> CallInfoSet
1939     filter_calls (CIS f calls) = CIS f (Map.filter keep_call calls)
1940     keep_call (_, fvs) = not (fvs `intersectsVarSet` bs)
1941
1942 deleteCallsFor :: [Id] -> CallDetails -> CallDetails
1943 -- Remove calls *for* bs
1944 deleteCallsFor bs calls = delVarEnvList calls bs
1945 \end{code}
1946
1947
1948 %************************************************************************
1949 %*                                                                      *
1950 \subsubsection{Boring helper functions}
1951 %*                                                                      *
1952 %************************************************************************
1953
1954 \begin{code}
1955 newtype SpecM a = SpecM (State SpecState a)
1956
1957 data SpecState = SpecState {
1958                      spec_uniq_supply :: UniqSupply,
1959                      spec_dflags :: DynFlags
1960                  }
1961
1962 instance Functor SpecM where
1963     fmap = liftM
1964
1965 instance Applicative SpecM where
1966     pure = return
1967     (<*>) = ap
1968
1969 instance Monad SpecM where
1970     SpecM x >>= f = SpecM $ do y <- x
1971                                case f y of
1972                                    SpecM z ->
1973                                        z
1974     return x = SpecM $ return x
1975     fail str = SpecM $ fail str
1976
1977 instance MonadUnique SpecM where
1978     getUniqueSupplyM
1979         = SpecM $ do st <- get
1980                      let (us1, us2) = splitUniqSupply $ spec_uniq_supply st
1981                      put $ st { spec_uniq_supply = us2 }
1982                      return us1
1983
1984     getUniqueM
1985         = SpecM $ do st <- get
1986                      let (u,us') = takeUniqFromSupply $ spec_uniq_supply st
1987                      put $ st { spec_uniq_supply = us' }
1988                      return u
1989
1990 instance HasDynFlags SpecM where
1991     getDynFlags = SpecM $ liftM spec_dflags get
1992
1993 runSpecM :: DynFlags -> SpecM a -> CoreM a
1994 runSpecM dflags (SpecM spec)
1995     = do us <- getUniqueSupplyM
1996          let initialState = SpecState {
1997                                 spec_uniq_supply = us,
1998                                 spec_dflags = dflags
1999                             }
2000          return $ evalState spec initialState
2001
2002 mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
2003 mapAndCombineSM _ []     = return ([], emptyUDs)
2004 mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
2005                               (ys, uds2) <- mapAndCombineSM f xs
2006                               return (y:ys, uds1 `plusUDs` uds2)
2007
2008 extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
2009 extendTvSubstList env tv_binds 
2010   = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }
2011
2012 substTy :: SpecEnv -> Type -> Type
2013 substTy env ty = CoreSubst.substTy (se_subst env) ty
2014
2015 substCo :: SpecEnv -> Coercion -> Coercion
2016 substCo env co = CoreSubst.substCo (se_subst env) co
2017
2018 substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
2019 substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of
2020                       (subst', bs') -> (env { se_subst = subst' }, bs')
2021
2022 substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
2023 substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of
2024                       (subst', bs') -> (env { se_subst = subst' }, bs')
2025
2026 cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
2027 -- Clone the binders of the bind; return new bind with the cloned binders
2028 -- Return the substitution to use for RHSs, and the one to use for the body
2029 cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)
2030   = do { us <- getUniqueSupplyM
2031        ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr
2032              interesting' | interestingDict env rhs 
2033                           = interesting `extendVarSet` bndr'
2034                           | otherwise = interesting
2035        ; return (env, env { se_subst = subst', se_interesting = interesting' }
2036                 , NonRec bndr' rhs) }
2037
2038 cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)
2039   = do { us <- getUniqueSupplyM
2040        ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)
2041              env' = env { se_subst = subst'
2042                         , se_interesting = interesting `extendVarSetList` 
2043                                            [ v | (v,r) <- pairs, interestingDict env r ] }
2044        ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }
2045
2046 newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
2047 -- Make up completely fresh binders for the dictionaries
2048 -- Their bindings are going to float outwards
2049 newDictBndr env b = do { uniq <- getUniqueM
2050                        ; let n   = idName b
2051                              ty' = substTy env (idType b)
2052                        ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }
2053
2054 newSpecIdSM :: Id -> Type -> SpecM Id
2055     -- Give the new Id a similar occurrence name to the old one
2056 newSpecIdSM old_id new_ty
2057   = do  { uniq <- getUniqueM
2058         ; let name    = idName old_id
2059               new_occ = mkSpecOcc (nameOccName name)
2060               new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
2061         ; return new_id }
2062 \end{code}
2063
2064
2065                 Old (but interesting) stuff about unboxed bindings
2066                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2067
2068 What should we do when a value is specialised to a *strict* unboxed value?
2069
2070         map_*_* f (x:xs) = let h = f x
2071                                t = map f xs
2072                            in h:t
2073
2074 Could convert let to case:
2075
2076         map_*_Int# f (x:xs) = case f x of h# ->
2077                               let t = map f xs
2078                               in h#:t
2079
2080 This may be undesirable since it forces evaluation here, but the value
2081 may not be used in all branches of the body. In the general case this
2082 transformation is impossible since the mutual recursion in a letrec
2083 cannot be expressed as a case.
2084
2085 There is also a problem with top-level unboxed values, since our
2086 implementation cannot handle unboxed values at the top level.
2087
2088 Solution: Lift the binding of the unboxed value and extract it when it
2089 is used:
2090
2091         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
2092                                   t = map f xs
2093                               in case h of
2094                                  _Lift h# -> h#:t
2095
2096 Now give it to the simplifier and the _Lifting will be optimised away.
2097
2098 The benfit is that we have given the specialised "unboxed" values a
2099 very simplep lifted semantics and then leave it up to the simplifier to
2100 optimise it --- knowing that the overheads will be removed in nearly
2101 all cases.
2102
2103 In particular, the value will only be evaluted in the branches of the
2104 program which use it, rather than being forced at the point where the
2105 value is bound. For example:
2106
2107         filtermap_*_* p f (x:xs)
2108           = let h = f x
2109                 t = ...
2110             in case p x of
2111                 True  -> h:t
2112                 False -> t
2113    ==>
2114         filtermap_*_Int# p f (x:xs)
2115           = let h = case (f x) of h# -> _Lift h#
2116                 t = ...
2117             in case p x of
2118                 True  -> case h of _Lift h#
2119                            -> h#:t
2120                 False -> t
2121
2122 The binding for h can still be inlined in the one branch and the
2123 _Lifting eliminated.
2124
2125
2126 Question: When won't the _Lifting be eliminated?
2127
2128 Answer: When they at the top-level (where it is necessary) or when
2129 inlining would duplicate work (or possibly code depending on
2130 options). However, the _Lifting will still be eliminated if the
2131 strictness analyser deems the lifted binding strict.
2132