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