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