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