3 1. Use a library type rather than an annotation for ForceSpecConstr
7 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
9 \section[SpecConstr]{Specialise over constructors}
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and fix
14 -- any warnings in the module. See
15 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
21 , SpecConstrAnnotation(..)
25 #include "HsVersions.h"
30 import CoreUnfold ( couldBeSmallEnoughToInline )
31 import CoreFVs ( exprsFreeVars )
33 import HscTypes ( ModGuts(..) )
34 import WwLib ( mkWorkerArgs )
36 import Coercion hiding( substTy, substCo )
38 import Type hiding ( substTy )
40 import MkCore ( mkImpossibleExpr )
46 import DynFlags ( DynFlags(..) )
47 import StaticFlags ( opt_PprStyle_Debug )
48 import Maybes ( orElse, catMaybes, isJust, isNothing )
50 import DmdAnal ( both )
51 import Serialized ( deserializeWithData )
59 import Control.Monad ( zipWithM )
63 -- See Note [SpecConstrAnnotation]
65 type SpecConstrAnnotation = ()
67 import TyCon ( TyCon )
68 import GHC.Exts( SpecConstrAnnotation(..) )
72 -----------------------------------------------------
74 -----------------------------------------------------
79 drop n (x:xs) = drop (n-1) xs
81 After the first time round, we could pass n unboxed. This happens in
82 numerical code too. Here's what it looks like in Core:
84 drop n xs = case xs of
89 _ -> drop (I# (n# -# 1#)) xs
91 Notice that the recursive call has an explicit constructor as argument.
92 Noticing this, we can make a specialised version of drop
94 RULE: drop (I# n#) xs ==> drop' n# xs
96 drop' n# xs = let n = I# n# in ...orig RHS...
98 Now the simplifier will apply the specialisation in the rhs of drop', giving
100 drop' n# xs = case xs of
104 _ -> drop (n# -# 1#) xs
108 We'd also like to catch cases where a parameter is carried along unchanged,
109 but evaluated each time round the loop:
111 f i n = if i>0 || i>n then i else f (i*2) n
113 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
114 In Core, by the time we've w/wd (f is strict in i) we get
116 f i# n = case i# ># 0 of
118 True -> case n of n' { I# n# ->
121 True -> f (i# *# 2#) n'
123 At the call to f, we see that the argument, n is know to be (I# n#),
124 and n is evaluated elsewhere in the body of f, so we can play the same
130 We must be careful not to allocate the same constructor twice. Consider
131 f p = (...(case p of (a,b) -> e)...p...,
132 ...let t = (r,s) in ...t...(f t)...)
133 At the recursive call to f, we can see that t is a pair. But we do NOT want
134 to make a specialised copy:
135 f' a b = let p = (a,b) in (..., ...)
136 because now t is allocated by the caller, then r and s are passed to the
137 recursive call, which allocates the (r,s) pair again.
140 (a) the argument p is used in other than a case-scrutinsation way.
141 (b) the argument to the call is not a 'fresh' tuple; you have to
142 look into its unfolding to see that it's a tuple
144 Hence the "OR" part of Note [Good arguments] below.
146 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
147 allocation, but does perhaps save evals. In the RULE we'd have
150 f (I# x#) = f' (I# x#) x#
152 If at the call site the (I# x) was an unfolding, then we'd have to
153 rely on CSE to eliminate the duplicate allocation.... This alternative
154 doesn't look attractive enough to pursue.
156 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
157 the conservative reboxing story prevents many useful functions from being
158 specialised. Example:
159 foo :: Maybe Int -> Int -> Int
161 foo x@(Just m) n = foo x (n-m)
162 Here the use of 'x' will clearly not require boxing in the specialised function.
164 The strictness analyser has the same problem, in fact. Example:
166 If we pass just 'a' and 'b' to the worker, it might need to rebox the
167 pair to create (a,b). A more sophisticated analysis might figure out
168 precisely the cases in which this could happen, but the strictness
169 analyser does no such analysis; it just passes 'a' and 'b', and hopes
172 So my current choice is to make SpecConstr similarly aggressive, and
173 ignore the bad potential of reboxing.
176 Note [Good arguments]
177 ~~~~~~~~~~~~~~~~~~~~~
180 * A self-recursive function. Ignore mutual recursion for now,
181 because it's less common, and the code is simpler for self-recursion.
185 a) At a recursive call, one or more parameters is an explicit
186 constructor application
188 That same parameter is scrutinised by a case somewhere in
189 the RHS of the function
193 b) At a recursive call, one or more parameters has an unfolding
194 that is an explicit constructor application
196 That same parameter is scrutinised by a case somewhere in
197 the RHS of the function
199 Those are the only uses of the parameter (see Note [Reboxing])
202 What to abstract over
203 ~~~~~~~~~~~~~~~~~~~~~
204 There's a bit of a complication with type arguments. If the call
207 f p = ...f ((:) [a] x xs)...
209 then our specialised function look like
211 f_spec x xs = let p = (:) [a] x xs in ....as before....
213 This only makes sense if either
214 a) the type variable 'a' is in scope at the top of f, or
215 b) the type variable 'a' is an argument to f (and hence fs)
217 Actually, (a) may hold for value arguments too, in which case
218 we may not want to pass them. Supose 'x' is in scope at f's
219 defn, but xs is not. Then we'd like
221 f_spec xs = let p = (:) [a] x xs in ....as before....
223 Similarly (b) may hold too. If x is already an argument at the
224 call, no need to pass it again.
226 Finally, if 'a' is not in scope at the call site, we could abstract
227 it as we do the term variables:
229 f_spec a x xs = let p = (:) [a] x xs in ...as before...
231 So the grand plan is:
233 * abstract the call site to a constructor-only pattern
234 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
236 * Find the free variables of the abstracted pattern
238 * Pass these variables, less any that are in scope at
239 the fn defn. But see Note [Shadowing] below.
242 NOTICE that we only abstract over variables that are not in scope,
243 so we're in no danger of shadowing variables used in "higher up"
249 In this pass we gather up usage information that may mention variables
250 that are bound between the usage site and the definition site; or (more
251 seriously) may be bound to something different at the definition site.
254 f x = letrec g y v = let x = ...
257 Since 'x' is in scope at the call site, we may make a rewrite rule that
259 RULE forall a,b. g (a,b) x = ...
260 But this rule will never match, because it's really a different 'x' at
261 the call site -- and that difference will be manifest by the time the
262 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
263 no-shadowing, so perhaps it may not be distinct?]
265 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
266 is to run deShadowBinds before running SpecConstr, but instead we run the
267 simplifier. That gives the simplest possible program for SpecConstr to
268 chew on; and it virtually guarantees no shadowing.
270 Note [Specialising for constant parameters]
271 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
272 This one is about specialising on a *constant* (but not necessarily
273 constructor) argument
275 foo :: Int -> (Int -> Int) -> Int
277 foo m f = foo (f m) (+1)
281 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
283 \ (ds_dlk :: GHC.Base.Int) ->
284 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
285 GHC.Base.I# (GHC.Prim.+# x_alG 1)
287 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
290 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
291 case ww_sme of ds_Xlw {
293 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
294 T.$wfoo ww1_Xmz lvl_rmV
299 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
300 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
302 When is this worth it? Call the constant 'lvl'
303 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
304 parameter is scrutinised anywhere in the body.
306 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
307 parameter is applied (...to enough arguments...?)
309 Also do this is if the function has RULES?
313 Note [Specialising for lambda parameters]
314 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
315 foo :: Int -> (Int -> Int) -> Int
317 foo m f = foo (f m) (\n -> n-m)
319 This is subtly different from the previous one in that we get an
320 explicit lambda as the argument:
322 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
325 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
326 case ww_sm8 of ds_Xlr {
328 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
331 (\ (n_ad3 :: GHC.Base.Int) ->
332 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
333 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
339 I wonder if SpecConstr couldn't be extended to handle this? After all,
340 lambda is a sort of constructor for functions and perhaps it already
341 has most of the necessary machinery?
343 Furthermore, there's an immediate win, because you don't need to allocate the lamda
344 at the call site; and if perchance it's called in the recursive call, then you
345 may avoid allocating it altogether. Just like for constructors.
347 Looks cool, but probably rare...but it might be easy to implement.
350 Note [SpecConstr for casts]
351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
354 data instance T Int = T Int
359 go (T n) = go (T (n-1))
361 The recursive call ends up looking like
362 go (T (I# ...) `cast` g)
363 So we want to spot the construtor application inside the cast.
364 That's why we have the Cast case in argToPat
366 Note [Local recursive groups]
367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368 For a *local* recursive group, we can see all the calls to the
369 function, so we seed the specialisation loop from the calls in the
370 body, not from the calls in the RHS. Consider:
372 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
376 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
377 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
378 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
379 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
381 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
382 most of which are not needed. But if we start with the (single) call
383 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
384 the recursive calls go to this fully-specialised copy. Indeed, the original
385 function is later collected as dead code. This is very important in
386 specialising the loops arising from stream fusion, for example in NDP where
387 we were getting literally hundreds of (mostly unused) specialisations of
390 In a case like the above we end up never calling the original un-specialised
391 function. (Although we still leave its code around just in case.)
393 However, if we find any boring calls in the body, including *unsaturated*
395 letrec foo x y = ....foo...
397 then we will end up calling the un-specialised function, so then we *should*
398 use the calls in the un-specialised RHS as seeds. We call these "boring
399 call patterns, and callsToPats reports if it finds any of these.
402 Note [Do not specialise diverging functions]
403 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
404 Specialising a function that just diverges is a waste of code.
405 Furthermore, it broke GHC (simpl014) thus:
407 f = \x. case x of (a,b) -> f x
408 If we specialise f we get
409 f = \x. case x of (a,b) -> fspec a b
410 But fspec doesn't have decent strictnes info. As it happened,
411 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
412 and hence f. But now f's strictness is less than its arity, which
415 Note [SpecConstrAnnotation]
416 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
417 SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
418 be available in stage 2 (well, until the bootstrap compiler can be
419 guaranteed to have it)
421 So we define it to be () in stage1 (ie when GHCI is undefined), and
422 '#ifdef' out the code that uses it.
424 See also Note [Forcing specialisation]
426 Note [Forcing specialisation]
427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
428 With stream fusion and in other similar cases, we want to fully specialise
429 some (but not necessarily all!) loops regardless of their size and the
430 number of specialisations. We allow a library to specify this by annotating
431 a type with ForceSpecConstr and then adding a parameter of that type to the
432 loop. Here is a (simplified) example from the vector library:
434 data SPEC = SPEC | SPEC2
435 {-# ANN type SPEC ForceSpecConstr #-}
437 foldl :: (a -> b -> a) -> a -> Stream b -> a
439 foldl f z (Stream step s _) = foldl_loop SPEC z s
441 foldl_loop !sPEC z s = case step s of
442 Yield x s' -> foldl_loop sPEC (f z x) s'
443 Skip -> foldl_loop sPEC z s'
446 SpecConstr will spot the SPEC parameter and always fully specialise
447 foldl_loop. Note that
449 * We have to prevent the SPEC argument from being removed by
450 w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
453 * And lastly, the SPEC argument is ultimately eliminated by
454 SpecConstr itself so there is no runtime overhead.
456 This is all quite ugly; we ought to come up with a better design.
458 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
459 sc_force to True when calling specLoop. This flag does three things:
460 * Ignore specConstrThreshold, to specialise functions of arbitrary size
462 * Ignore specConstrCount, to make arbitrary numbers of specialisations
464 * Specialise even for arguments that are not scrutinised in the loop
465 (see argToPat; Trac #4488)
467 This flag is inherited for nested non-recursive bindings (which are likely to
468 be join points and hence should be fully specialised) but reset for nested
471 What alternatives did I consider? Annotating the loop itself doesn't
472 work because (a) it is local and (b) it will be w/w'ed and I having
473 w/w propagating annotation somehow doesn't seem like a good idea. The
474 types of the loop arguments really seem to be the most persistent
477 Annotating the types that make up the loop state doesn't work,
478 either, because (a) it would prevent us from using types like Either
479 or tuples here, (b) we don't want to restrict the set of types that
480 can be used in Stream states and (c) some types are fixed by the user
481 (e.g., the accumulator here) but we still want to specialise as much
484 ForceSpecConstr is done by way of an annotation:
485 data SPEC = SPEC | SPEC2
486 {-# ANN type SPEC ForceSpecConstr #-}
487 But SPEC is the *only* type so annotated, so it'd be better to
488 use a particular library type.
490 Alternatives to ForceSpecConstr
491 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
492 Instead of giving the loop an extra argument of type SPEC, we
493 also considered *wrapping* arguments in SPEC, thus
494 data SPEC a = SPEC a | SPEC2
496 loop = \arg -> case arg of
498 case state of (x,y) -> ... loop (SPEC (x',y')) ...
500 The idea is that a SPEC argument says "specialise this argument
501 regardless of whether the function case-analyses it. But this
503 * SPEC must still be a sum type, else the strictness analyser
505 * But that means that 'loop' won't be strict in its real payload
506 This loss of strictness in turn screws up specialisation, because
507 we may end up with calls like
508 loop (SPEC (case z of (p,q) -> (q,p)))
509 Without the SPEC, if 'loop' was strict, the case would move out
510 and we'd see loop applied to a pair. But if 'loop' isn' strict
511 this doesn't look like a specialisable call.
515 The ignoreDataCon stuff allows you to say
516 {-# ANN type T NoSpecConstr #-}
517 to mean "don't specialise on arguments of this type. It was added
518 before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised
519 regardless of size; and then we needed a way to turn that *off*. Now
520 that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
521 (Used only for PArray.)
523 -----------------------------------------------------
524 Stuff not yet handled
525 -----------------------------------------------------
527 Here are notes arising from Roman's work that I don't want to lose.
533 foo :: Int -> T Int -> Int
535 foo x t | even x = case t of { T n -> foo (x-n) t }
536 | otherwise = foo (x-1) t
538 SpecConstr does no specialisation, because the second recursive call
539 looks like a boxed use of the argument. A pity.
541 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
543 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
544 case ww_sFo of ds_Xw6 [Just L] {
546 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
547 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
549 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
550 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
551 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
557 data a :*: b = !a :*: !b
560 foo :: (Int :*: T Int) -> Int
562 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
563 | otherwise = foo ((x-1) :*: t)
565 Very similar to the previous one, except that the parameters are now in
566 a strict tuple. Before SpecConstr, we have
568 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
570 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
572 case ww_sFU of ds_Xws [Just L] {
574 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
576 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
577 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
580 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
581 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
582 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
586 We get two specialisations:
587 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
588 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
589 = Foo.$s$wfoo1 a_sFB sc_sGC ;
590 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
591 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
592 = Foo.$s$wfoo y_aFp sc_sGC ;
594 But perhaps the first one isn't good. After all, we know that tpl_B2 is
595 a T (I# x) really, because T is strict and Int has one constructor. (We can't
596 unbox the strict fields, becuase T is polymorphic!)
598 %************************************************************************
600 \subsection{Top level wrapper stuff}
602 %************************************************************************
605 specConstrProgram :: ModGuts -> CoreM ModGuts
606 specConstrProgram guts
608 dflags <- getDynFlags
609 us <- getUniqueSupplyM
610 annos <- getFirstAnnotations deserializeWithData guts
611 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
612 return (guts { mg_binds = binds' })
615 go env (bind:binds) = do (env', bind') <- scTopBind env bind
616 binds' <- go env' binds
617 return (bind' : binds')
621 %************************************************************************
623 \subsection{Environment: goes downwards}
625 %************************************************************************
628 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
629 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
630 -- See Note [Avoiding exponential blowup]
631 sc_force :: Bool, -- Force specialisation?
632 -- See Note [Forcing specialisation]
634 sc_subst :: Subst, -- Current substitution
635 -- Maps InIds to OutExprs
637 sc_how_bound :: HowBoundEnv,
638 -- Binds interesting non-top-level variables
639 -- Domain is OutVars (*after* applying the substitution)
642 -- Domain is OutIds (*after* applying the substitution)
643 -- Used even for top-level bindings (but not imported ones)
645 sc_annotations :: UniqFM SpecConstrAnnotation
648 ---------------------
649 -- As we go, we apply a substitution (sc_subst) to the current term
650 type InExpr = CoreExpr -- _Before_ applying the subst
653 type OutExpr = CoreExpr -- _After_ applying the subst
657 ---------------------
658 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
660 ---------------------
661 type ValueEnv = IdEnv Value -- Domain is OutIds
662 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
663 -- The AltCon is never DEFAULT
664 | LambdaVal -- Inlinable lambdas or PAPs
666 instance Outputable Value where
667 ppr (ConVal con args) = ppr con <+> interpp'SP args
668 ppr LambdaVal = ptext (sLit "<Lambda>")
670 ---------------------
671 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
672 initScEnv dflags anns
673 = SCE { sc_size = specConstrThreshold dflags,
674 sc_count = specConstrCount dflags,
676 sc_subst = emptySubst,
677 sc_how_bound = emptyVarEnv,
678 sc_vals = emptyVarEnv,
679 sc_annotations = anns }
681 data HowBound = RecFun -- These are the recursive functions for which
682 -- we seek interesting call patterns
684 | RecArg -- These are those functions' arguments, or their sub-components;
685 -- we gather occurrence information for these
687 instance Outputable HowBound where
688 ppr RecFun = text "RecFun"
689 ppr RecArg = text "RecArg"
691 scForce :: ScEnv -> Bool -> ScEnv
692 scForce env b = env { sc_force = b }
694 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
695 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
697 scSubstId :: ScEnv -> Id -> CoreExpr
698 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
700 scSubstTy :: ScEnv -> Type -> Type
701 scSubstTy env ty = substTy (sc_subst env) ty
703 scSubstCo :: ScEnv -> Coercion -> Coercion
704 scSubstCo env co = substCo (sc_subst env) co
706 zapScSubst :: ScEnv -> ScEnv
707 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
709 extendScInScope :: ScEnv -> [Var] -> ScEnv
710 -- Bring the quantified variables into scope
711 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
713 -- Extend the substitution
714 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
715 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
717 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
718 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
720 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
721 extendHowBound env bndrs how_bound
722 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
723 [(bndr,how_bound) | bndr <- bndrs] }
725 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
726 extendBndrsWith how_bound env bndrs
727 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
729 (subst', bndrs') = substBndrs (sc_subst env) bndrs
730 hb_env' = sc_how_bound env `extendVarEnvList`
731 [(bndr,how_bound) | bndr <- bndrs']
733 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
734 extendBndrWith how_bound env bndr
735 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
737 (subst', bndr') = substBndr (sc_subst env) bndr
738 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
740 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
741 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
743 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
745 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
746 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
748 (subst', bndr') = substBndr (sc_subst env) bndr
750 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
751 extendValEnv env _ Nothing = env
752 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
754 extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
758 -- we want to bind b, to (C x y)
759 -- NB1: Extends only the sc_vals part of the envt
760 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
761 -- they are potentially made alive by the [b -> C x y] binding
762 extendCaseBndrs env scrut case_bndr con alt_bndrs
765 live_case_bndr = not (isDeadBinder case_bndr)
766 env1 | Var v <- scrut = extendValEnv env v cval
767 | otherwise = env -- See Note [Add scrutinee to ValueEnv too]
768 env2 | live_case_bndr = extendValEnv env1 case_bndr cval
771 alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
778 LitAlt {} -> Just (ConVal con [])
779 DataAlt {} -> Just (ConVal con vanilla_args)
781 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
782 varsToCoreExprs alt_bndrs
784 zap v | isTyVar v = v -- See NB2 above
785 | otherwise = zapIdOccInfo v
788 decreaseSpecCount :: ScEnv -> Int -> ScEnv
789 -- See Note [Avoiding exponential blowup]
790 decreaseSpecCount env n_specs
791 = env { sc_count = case sc_count env of
793 Just n -> Just (n `div` (n_specs + 1)) }
794 -- The "+1" takes account of the original function;
795 -- See Note [Avoiding exponential blowup]
797 ---------------------------------------------------
798 -- See Note [SpecConstrAnnotation]
799 ignoreType :: ScEnv -> Type -> Bool
800 ignoreDataCon :: ScEnv -> DataCon -> Bool
801 forceSpecBndr :: ScEnv -> Var -> Bool
803 ignoreType _ _ = False
804 ignoreDataCon _ _ = False
805 forceSpecBndr _ _ = False
809 ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
812 = case splitTyConApp_maybe ty of
813 Just (tycon, _) -> ignoreTyCon env tycon
816 ignoreTyCon :: ScEnv -> TyCon -> Bool
817 ignoreTyCon env tycon
818 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
820 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
822 forceSpecFunTy :: ScEnv -> Type -> Bool
823 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
825 forceSpecArgTy :: ScEnv -> Type -> Bool
826 forceSpecArgTy env ty
827 | Just ty' <- coreView ty = forceSpecArgTy env ty'
829 forceSpecArgTy env ty
830 | Just (tycon, tys) <- splitTyConApp_maybe ty
832 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
833 || any (forceSpecArgTy env) tys
835 forceSpecArgTy _ _ = False
839 Note [Add scrutinee to ValueEnv too]
840 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
845 By the time we get to the call (f y), the ValueEnv
846 will have a binding for y, and for c
849 BUT that's not enough! Looking at the call (f y) we
850 see that y is pair (a,b), but we also need to know what 'b' is.
851 So in extendCaseBndrs we must *also* add the binding
853 else we lose a useful specialisation for f. This is necessary even
854 though the simplifier has systematically replaced uses of 'x' with 'y'
855 and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came
856 from outside the case. See Trac #4908 for the live example.
858 Note [Avoiding exponential blowup]
859 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
860 The sc_count field of the ScEnv says how many times we are prepared to
861 duplicate a single function. But we must take care with recursive
862 specialiations. Consider
864 let $j1 = let $j2 = let $j3 = ...
872 If we specialise $j1 then in each specialisation (as well as the original)
873 we can specialise $j2, and similarly $j3. Even if we make just *one*
874 specialisation of each, becuase we also have the original we'll get 2^n
875 copies of $j3, which is not good.
877 So when recursively specialising we divide the sc_count by the number of
878 copies we are making at this level, including the original.
881 %************************************************************************
883 \subsection{Usage information: flows upwards}
885 %************************************************************************
890 scu_calls :: CallEnv, -- Calls
891 -- The functions are a subset of the
892 -- RecFuns in the ScEnv
894 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
895 } -- The domain is OutIds
897 type CallEnv = IdEnv [Call]
898 type Call = (ValueEnv, [CoreArg])
899 -- The arguments of the call, together with the
900 -- env giving the constructor bindings at the call site
903 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
905 combineCalls :: CallEnv -> CallEnv -> CallEnv
906 combineCalls = plusVarEnv_C (++)
908 combineUsage :: ScUsage -> ScUsage -> ScUsage
909 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
910 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
912 combineUsages :: [ScUsage] -> ScUsage
913 combineUsages [] = nullUsage
914 combineUsages us = foldr1 combineUsage us
916 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
917 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
918 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
919 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
921 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
922 | UnkOcc -- Used in some unknown way
924 | ScrutOcc -- See Note [ScrutOcc]
925 (DataConEnv [ArgOcc]) -- How the sub-components are used
927 type DataConEnv a = UniqFM a -- Keyed by DataCon
931 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
932 is *only* taken apart or applied.
934 Functions, literal: ScrutOcc emptyUFM
935 Data constructors: ScrutOcc subs,
937 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
938 The domain of the UniqFM is the Unique of the data constructor
940 The [ArgOcc] is the occurrences of the *pattern-bound* components
941 of the data structure. E.g.
942 data T a = forall b. MkT a b (b->a)
943 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
947 instance Outputable ArgOcc where
948 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
949 ppr UnkOcc = ptext (sLit "unk-occ")
950 ppr NoOcc = ptext (sLit "no-occ")
952 evalScrutOcc :: ArgOcc
953 evalScrutOcc = ScrutOcc emptyUFM
955 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
956 -- that if the thing is scrutinised anywhere then we get to see that
957 -- in the overall result, even if it's also used in a boxed way
958 -- This might be too agressive; see Note [Reboxing] Alternative 3
959 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
960 combineOcc NoOcc occ = occ
961 combineOcc occ NoOcc = occ
962 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
963 combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys
964 combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs
965 combineOcc UnkOcc UnkOcc = UnkOcc
967 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
968 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
970 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
971 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
972 -- is a variable, and an interesting variable
973 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
974 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
975 setScrutOcc env usg (Var v) occ
976 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
978 setScrutOcc _env usg _other _occ -- Catch-all
982 %************************************************************************
984 \subsection{The main recursive function}
986 %************************************************************************
988 The main recursive function gathers up usage information, and
989 creates specialised versions of functions.
992 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
993 -- The unique supply is needed when we invent
994 -- a new name for the specialised function and its args
996 scExpr env e = scExpr' env e
999 scExpr' env (Var v) = case scSubstId env v of
1000 Var v' -> return (mkVarUsage env v' [], Var v')
1001 e' -> scExpr (zapScSubst env) e'
1003 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
1004 scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
1005 scExpr' _ e@(Lit {}) = return (nullUsage, e)
1006 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
1007 return (usg, Note n e')
1008 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
1009 return (usg, Cast e' (scSubstCo env co))
1010 scExpr' env e@(App _ _) = scApp env (collectArgs e)
1011 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
1012 (usg, e') <- scExpr env' e
1013 return (usg, Lam b' e')
1015 scExpr' env (Case scrut b ty alts)
1016 = do { (scrut_usg, scrut') <- scExpr env scrut
1017 ; case isValue (sc_vals env) scrut' of
1018 Just (ConVal con args) -> sc_con_app con args scrut'
1019 _other -> sc_vanilla scrut_usg scrut'
1022 sc_con_app con args scrut' -- Known constructor; simplify
1023 = do { let (_, bs, rhs) = findAlt con alts
1024 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
1025 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
1026 ; scExpr alt_env' rhs }
1028 sc_vanilla scrut_usg scrut' -- Normal case
1029 = do { let (alt_env,b') = extendBndrWith RecArg env b
1030 -- Record RecArg for the components
1032 ; (alt_usgs, alt_occs, alts')
1033 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
1035 ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty
1036 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
1037 -- The combined usage of the scrutinee is given
1038 -- by scrut_occ, which is passed to scScrut, which
1039 -- in turn treats a bare-variable scrutinee specially
1041 ; return (foldr combineUsage scrut_usg' alt_usgs,
1042 Case scrut' b' (scSubstTy env ty) alts') }
1044 sc_alt env scrut' b' (con,bs,rhs)
1045 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
1046 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
1047 ; (usg, rhs') <- scExpr env2 rhs
1048 ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
1049 scrut_occ = case con of
1050 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
1051 _ -> ScrutOcc emptyUFM
1052 ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
1054 scExpr' env (Let (NonRec bndr rhs) body)
1055 | isTyVar bndr -- Type-lets may be created by doBeta
1056 = scExpr' (extendScSubst env bndr rhs) body
1059 = do { let (body_env, bndr') = extendBndr env bndr
1060 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
1062 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
1063 -- Note [Local let bindings]
1064 RI _ rhs' _ _ _ = rhs_info
1065 body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
1067 ; (body_usg, body') <- scExpr body_env3 body
1069 -- NB: For non-recursive bindings we inherit sc_force flag from
1070 -- the parent function (see Note [Forcing specialisation])
1071 ; (spec_usg, specs) <- specialise env
1072 (scu_calls body_usg)
1074 (SI [] 0 (Just rhs_usg))
1076 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1077 `combineUsage` rhs_usg `combineUsage` spec_usg,
1078 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1082 -- A *local* recursive group: see Note [Local recursive groups]
1083 scExpr' env (Let (Rec prs) body)
1084 = do { let (bndrs,rhss) = unzip prs
1085 (rhs_env1,bndrs') = extendRecBndrs env bndrs
1086 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1087 force_spec = any (forceSpecBndr env) bndrs'
1088 -- Note [Forcing specialisation]
1090 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1091 ; (body_usg, body') <- scExpr rhs_env2 body
1093 -- NB: start specLoop from body_usg
1094 ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
1095 (scu_calls body_usg) rhs_infos nullUsage
1096 [SI [] 0 (Just usg) | usg <- rhs_usgs]
1097 -- Do not unconditionally generate specialisations from rhs_usgs
1098 -- Instead use them only if we find an unspecialised call
1099 -- See Note [Local recursive groups]
1101 ; let rhs_usg = combineUsages rhs_usgs
1102 all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg
1103 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1105 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1109 Note [Local let bindings]
1110 ~~~~~~~~~~~~~~~~~~~~~~~~~
1111 It is not uncommon to find this
1113 let $j = \x. <blah> in ...$j True...$j True...
1115 Here $j is an arbitrary let-bound function, but it often comes up for
1116 join points. We might like to specialise $j for its call patterns.
1117 Notice the difference from a letrec, where we look for call patterns
1118 in the *RHS* of the function. Here we look for call patterns in the
1121 At one point I predicated this on the RHS mentioning the outer
1122 recursive function, but that's not essential and might even be
1123 harmful. I'm not sure.
1127 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1129 scApp env (Var fn, args) -- Function is a variable
1130 = ASSERT( not (null args) )
1131 do { args_w_usgs <- mapM (scExpr env) args
1132 ; let (arg_usgs, args') = unzip args_w_usgs
1133 arg_usg = combineUsages arg_usgs
1134 ; case scSubstId env fn of
1135 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1136 -- Do beta-reduction and try again
1138 Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
1139 mkApps (Var fn') args')
1141 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1142 -- NB: doing this ignores any usage info from the substituted
1143 -- function, but I don't think that matters. If it does
1146 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1147 -- ToDo: adjust for System IF
1148 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1149 doBeta fn args = mkApps fn args
1151 -- The function is almost always a variable, but not always.
1152 -- In particular, if this pass follows float-in,
1153 -- which it may, we can get
1154 -- (let f = ...f... in f) arg1 arg2
1155 scApp env (other_fn, args)
1156 = do { (fn_usg, fn') <- scExpr env other_fn
1157 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1158 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1160 ----------------------
1161 mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
1162 mkVarUsage env fn args
1163 = case lookupHowBound env fn of
1164 Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)]
1165 , scu_occs = emptyVarEnv }
1166 Just RecArg -> SCU { scu_calls = emptyVarEnv
1167 , scu_occs = unitVarEnv fn arg_occ }
1168 Nothing -> nullUsage
1170 -- I rather think we could use UnkOcc all the time
1171 arg_occ | null args = UnkOcc
1172 | otherwise = evalScrutOcc
1174 ----------------------
1175 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1176 scTopBind env (Rec prs)
1177 | Just threshold <- sc_size env
1179 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1180 -- No specialisation
1181 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1182 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1183 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1184 | otherwise -- Do specialisation
1185 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1186 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1188 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1189 ; let rhs_usg = combineUsages rhs_usgs
1191 ; (_, specs) <- specLoop (scForce rhs_env2 force_spec)
1192 (scu_calls rhs_usg) rhs_infos nullUsage
1193 [SI [] 0 Nothing | _ <- bndrs]
1195 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1196 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1198 (bndrs,rhss) = unzip prs
1199 force_spec = any (forceSpecBndr env) bndrs
1200 -- Note [Forcing specialisation]
1202 scTopBind env (NonRec bndr rhs)
1203 = do { (_, rhs') <- scExpr env rhs
1204 ; let (env1, bndr') = extendBndr env bndr
1205 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1206 ; return (env2, NonRec bndr' rhs') }
1208 ----------------------
1209 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1210 scRecRhs env (bndr,rhs)
1211 = do { let (arg_bndrs,body) = collectBinders rhs
1212 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1213 ; (body_usg, body') <- scExpr body_env body
1214 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1215 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1216 arg_bndrs body arg_occs) }
1217 -- The arg_occs says how the visible,
1218 -- lambda-bound binders of the RHS are used
1219 -- (including the TyVar binders)
1220 -- Two pats are the same if they match both ways
1222 ----------------------
1223 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1224 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1225 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1226 -- First the specialised bindings
1228 [(fn `addIdSpecialisations` rules, new_rhs)]
1229 -- And now the original binding
1231 rules = [r | OS _ r _ _ <- specs]
1235 %************************************************************************
1237 The specialiser itself
1239 %************************************************************************
1242 data RhsInfo = RI OutId -- The binder
1243 OutExpr -- The new RHS
1244 [InVar] InExpr -- The *original* RHS (\xs.body)
1245 -- Note [Specialise original body]
1246 [ArgOcc] -- Info on how the xs occur in body
1248 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1250 Int -- Length of specs; used for numbering them
1252 (Maybe ScUsage) -- Just cs => we have not yet used calls in the
1253 -- from calls in the *original* RHS as
1254 -- seeds for new specialisations;
1255 -- if you decide to do so, here is the
1256 -- RHS usage (which has not yet been
1258 -- Nothing => we have
1259 -- See Note [Local recursive groups]
1261 -- One specialisation: Rule plus definition
1262 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1263 CoreRule -- Rule connecting original id with the specialisation
1264 OutId OutExpr -- Spec id + its rhs
1270 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1271 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1273 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1274 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1275 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1276 new_usg = combineUsages new_usg_s
1277 new_calls = scu_calls new_usg
1278 all_usg = usg_so_far `combineUsage` new_usg
1279 ; if isEmptyVarEnv new_calls then
1280 return (all_usg, all_specs)
1282 specLoop env new_calls rhs_infos all_usg all_specs }
1286 -> CallEnv -- Info on calls
1288 -> SpecInfo -- Original RHS plus patterns dealt with
1289 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1291 -- Note: this only generates *specialised* bindings
1292 -- The original binding is added by specInfoBinds
1294 -- Note: the rhs here is the optimised version of the original rhs
1295 -- So when we make a specialised copy of the RHS, we're starting
1296 -- from an RHS whose nested functions have been optimised already.
1298 specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
1299 spec_info@(SI specs spec_count mb_unspec)
1300 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1301 , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1302 , notNull arg_bndrs -- Only specialise functions
1303 , Just all_calls <- lookupVarEnv bind_calls fn
1304 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1305 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1306 -- , text "arg_occs" <+> ppr arg_occs
1307 -- , text "calls" <+> ppr all_calls
1308 -- , text "good pats" <+> ppr pats]) $
1311 -- Bale out if too many specialisations
1312 ; let n_pats = length pats
1313 spec_count' = n_pats + spec_count
1314 ; case sc_count env of
1315 Just max | not (sc_force env) && spec_count' > max
1316 -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for
1317 then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125
1318 return (nullUsage, spec_info)
1319 else return (nullUsage, spec_info)
1321 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1322 , nest 2 (ptext (sLit "has") <+>
1323 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1324 ptext (sLit "but the limit is") <+> int max) ]
1325 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1327 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1328 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1330 _normal_case -> do {
1332 let spec_env = decreaseSpecCount env n_pats
1333 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1334 (pats `zip` [spec_count..])
1335 -- See Note [Specialise original body]
1337 ; let spec_usg = combineUsages spec_usgs
1338 (new_usg, mb_unspec')
1340 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1341 _ -> (spec_usg, mb_unspec)
1343 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1345 = return (nullUsage, spec_info) -- The boring case
1348 ---------------------
1350 -> OutId -- Function
1351 -> [InVar] -- Lambda-binders of RHS; should match patterns
1352 -> InExpr -- Body of the original function
1354 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1356 -- spec_one creates a specialised copy of the function, together
1357 -- with a rule for using it. I'm very proud of how short this
1358 -- function is, considering what it does :-).
1364 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1365 [c::*, v::(b,c) are presumably bound by the (...) part]
1367 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1368 (...entire body of f...) [b -> (b,c),
1369 y -> ((:) (a,(b,c)) (x,v) hw)]
1371 RULE: forall b::* c::*, -- Note, *not* forall a, x
1375 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1378 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1379 = do { spec_uniq <- getUniqueUs
1380 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1381 (arg_bndrs `zip` pats)
1383 fn_loc = nameSrcSpan fn_name
1384 spec_occ = mkSpecOcc (nameOccName fn_name)
1385 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1386 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1387 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1390 -- Specialise the body
1391 ; (spec_usg, spec_body) <- scExpr spec_env body
1393 -- ; pprTrace "done spec_one}" (ppr fn) $
1396 -- And build the results
1397 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1398 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1399 `setIdArity` count isId spec_lam_args
1400 spec_str = calcSpecStrictness fn spec_lam_args pats
1401 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1402 -- Usual w/w hack to avoid generating
1403 -- a spec_rhs of unlifted type and no args
1405 spec_rhs = mkLams spec_lam_args spec_body
1406 body_ty = exprType spec_body
1407 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1408 inline_act = idInlineActivation fn
1409 rule = mkRule True {- Auto -} True {- Local -}
1410 rule_name inline_act fn_name qvars pats rule_rhs
1411 -- See Note [Transfer activation]
1412 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1414 calcSpecStrictness :: Id -- The original function
1415 -> [Var] -> [CoreExpr] -- Call pattern
1416 -> StrictSig -- Strictness of specialised thing
1417 -- See Note [Transfer strictness]
1418 calcSpecStrictness fn qvars pats
1419 = StrictSig (mkTopDmdType spec_dmds TopRes)
1421 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1422 StrictSig (DmdType _ dmds _) = idStrictness fn
1424 dmd_env = go emptyVarEnv dmds pats
1426 go env ds (Type {} : pats) = go env ds pats
1427 go env ds (Coercion {} : pats) = go env ds pats
1428 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1431 go_one env d (Var v) = extendVarEnv_C both env v d
1432 go_one env (Box d) e = go_one env d e
1433 go_one env (Eval (Prod ds)) e
1434 | (Var _, args) <- collectArgs e = go env ds args
1435 go_one env _ _ = env
1439 Note [Specialise original body]
1440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1441 The RhsInfo for a binding keeps the *original* body of the binding. We
1442 must specialise that, *not* the result of applying specExpr to the RHS
1443 (which is also kept in RhsInfo). Otherwise we end up specialising a
1444 specialised RHS, and that can lead directly to exponential behaviour.
1446 Note [Transfer activation]
1447 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1448 This note is for SpecConstr, but exactly the same thing
1449 happens in the overloading specialiser; see
1450 Note [Auto-specialisation and RULES] in Specialise.
1452 In which phase should the specialise-constructor rules be active?
1453 Originally I made them always-active, but Manuel found that this
1454 defeated some clever user-written rules. Then I made them active only
1455 in Phase 0; after all, currently, the specConstr transformation is
1456 only run after the simplifier has reached Phase 0, but that meant
1457 that specialisations didn't fire inside wrappers; see test
1458 simplCore/should_compile/spec-inline.
1460 So now I just use the inline-activation of the parent Id, as the
1461 activation for the specialiation RULE, just like the main specialiser;
1463 This in turn means there is no point in specialising NOINLINE things,
1464 so we test for that.
1466 Note [Transfer strictness]
1467 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1468 We must transfer strictness information from the original function to
1469 the specialised one. Suppose, for example
1472 and a RULE f (a:as) b = f_spec a as b
1474 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1475 when calling f_spec instead of call-by-value. And that can result in
1476 unbounded worsening in space (cf the classic foldl vs foldl')
1478 See Trac #3437 for a good example.
1480 The function calcSpecStrictness performs the calculation.
1483 %************************************************************************
1485 \subsection{Argument analysis}
1487 %************************************************************************
1489 This code deals with analysing call-site arguments to see whether
1490 they are constructor applications.
1494 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1496 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1497 -- Result has no duplicate patterns,
1498 -- nor ones mentioned in done_pats
1499 -- Bool indicates that there was at least one boring pattern
1500 callsToPats env done_specs bndr_occs calls
1501 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1503 ; let good_pats :: [CallPat]
1504 good_pats = catMaybes mb_pats
1505 done_pats = [p | OS p _ _ _ <- done_specs]
1506 is_done p = any (samePat p) done_pats
1508 ; return (any isNothing mb_pats,
1509 filterOut is_done (nubBy samePat good_pats)) }
1511 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1512 -- The [Var] is the variables to quantify over in the rule
1513 -- Type variables come first, since they may scope
1514 -- over the following term variables
1515 -- The [CoreExpr] are the argument patterns for the rule
1516 callToPats env bndr_occs (con_env, args)
1517 | length args < length bndr_occs -- Check saturated
1520 = do { let in_scope = substInScope (sc_subst env)
1521 ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
1522 ; let pat_fvs = varSetElems (exprsFreeVars pats)
1523 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1524 -- Quantify over variables that are not in sccpe
1526 -- See Note [Shadowing] at the top
1528 (tvs, ids) = partition isTyVar qvars
1530 -- Put the type variables first; the type of a term
1531 -- variable may mention a type variable
1533 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1535 then return (Just (qvars', pats))
1536 else return Nothing }
1538 -- argToPat takes an actual argument, and returns an abstracted
1539 -- version, consisting of just the "constructor skeleton" of the
1540 -- argument, with non-constructor sub-expression replaced by new
1541 -- placeholder variables. For example:
1542 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1545 -> InScopeSet -- What's in scope at the fn defn site
1546 -> ValueEnv -- ValueEnv at the call site
1547 -> CoreArg -- A call arg (or component thereof)
1549 -> UniqSM (Bool, CoreArg)
1551 -- Returns (interesting, pat),
1552 -- where pat is the pattern derived from the argument
1553 -- interesting=True if the pattern is non-trivial (not a variable or type)
1554 -- E.g. x:xs --> (True, x:xs)
1555 -- f xs --> (False, w) where w is a fresh wildcard
1556 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1557 -- \x. x+y --> (True, \x. x+y)
1558 -- lvl7 --> (True, lvl7) if lvl7 is bound
1559 -- somewhere further out
1561 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1562 = return (False, arg)
1564 argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ
1565 = return (False, arg)
1567 argToPat env in_scope val_env (Note _ arg) arg_occ
1568 = argToPat env in_scope val_env arg arg_occ
1569 -- Note [Notes in call patterns]
1570 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1571 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1572 -- Perhaps we should not ignore profiling notes, but I'm going to
1573 -- ride roughshod over them all for now.
1574 --- See Note [Notes in RULE matching] in Rules
1576 argToPat env in_scope val_env (Let _ arg) arg_occ
1577 = argToPat env in_scope val_env arg arg_occ
1578 -- See Note [Matching lets] in Rule.lhs
1579 -- Look through let expressions
1580 -- e.g. f (let v = rhs in (v,w))
1581 -- Here we can specialise for f (v,w)
1582 -- because the rule-matcher will look through the let.
1584 {- Disabled; see Note [Matching cases] in Rule.lhs
1585 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1586 | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
1587 = argToPat env in_scope val_env rhs arg_occ
1590 argToPat env in_scope val_env (Cast arg co) arg_occ
1591 | isReflCo co -- Substitution in the SpecConstr itself
1592 -- can lead to identity coercions
1593 = argToPat env in_scope val_env arg arg_occ
1594 | not (ignoreType env ty2)
1595 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1596 ; if not interesting then
1599 { -- Make a wild-card pattern for the coercion
1601 ; let co_name = mkSysTvName uniq (fsLit "sg")
1602 co_var = mkCoVar co_name (mkCoType ty1 ty2)
1603 ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
1605 Pair ty1 ty2 = coercionKind co
1609 {- Disabling lambda specialisation for now
1610 It's fragile, and the spec_loop can be infinite
1611 argToPat in_scope val_env arg arg_occ
1613 = return (True, arg)
1615 is_value_lam (Lam v e) -- Spot a value lambda, even if
1616 | isId v = True -- it is inside a type lambda
1617 | otherwise = is_value_lam e
1618 is_value_lam other = False
1621 -- Check for a constructor application
1622 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1623 argToPat env in_scope val_env arg arg_occ
1624 | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
1625 , not (ignoreDataCon env dc) -- See Note [NoSpecConstr]
1626 , Just arg_occs <- mb_scrut dc
1627 = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
1628 ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
1630 mkConApp dc (ty_args ++ args')) }
1632 mb_scrut dc = case arg_occ of
1634 | Just occs <- lookupUFM bs dc
1635 -> Just (occs) -- See Note [Reboxing]
1636 _other | sc_force env -> Just (repeat UnkOcc)
1637 | otherwise -> Nothing
1639 -- Check if the argument is a variable that
1640 -- (a) is used in an interesting way in the body
1641 -- (b) we know what its value is
1642 -- In that case it counts as "interesting"
1643 argToPat env in_scope val_env (Var v) arg_occ
1644 | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1646 not (ignoreType env (varType v))
1647 = return (True, Var v)
1650 | isLocalId v = v `elemInScopeSet` in_scope
1651 && isJust (lookupVarEnv val_env v)
1652 -- Local variables have values in val_env
1653 | otherwise = isValueUnfolding (idUnfolding v)
1654 -- Imports have unfoldings
1656 -- I'm really not sure what this comment means
1657 -- And by not wild-carding we tend to get forall'd
1658 -- variables that are in soope, which in turn can
1659 -- expose the weakness in let-matching
1660 -- See Note [Matching lets] in Rules
1662 -- Check for a variable bound inside the function.
1663 -- Don't make a wild-card, because we may usefully share
1664 -- e.g. f a = let x = ... in f (x,x)
1665 -- NB: this case follows the lambda and con-app cases!!
1666 -- argToPat _in_scope _val_env (Var v) _arg_occ
1667 -- = return (False, Var v)
1668 -- SLPJ : disabling this to avoid proliferation of versions
1669 -- also works badly when thinking about seeding the loop
1670 -- from the body of the let
1671 -- f x y = letrec g z = ... in g (x,y)
1672 -- We don't want to specialise for that *particular* x,y
1674 -- The default case: make a wild-card
1675 argToPat _env _in_scope _val_env arg _arg_occ
1676 = wildCardPat (exprType arg)
1678 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1680 = do { uniq <- getUniqueUs
1681 ; let id = mkSysLocal (fsLit "sc") uniq ty
1682 ; return (False, Var id) }
1684 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1685 -> [CoreArg] -> [ArgOcc] -- Should be same length
1686 -> UniqSM (Bool, [CoreArg])
1687 argsToPats env in_scope val_env args occs
1688 = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
1689 ; let (interesting_s, args') = unzip stuff
1690 ; return (or interesting_s, args') }
1695 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1696 isValue _env (Lit lit)
1697 = Just (ConVal (LitAlt lit) [])
1700 | Just stuff <- lookupVarEnv env v
1701 = Just stuff -- You might think we could look in the idUnfolding here
1702 -- but that doesn't take account of which branch of a
1703 -- case we are in, which is the whole point
1705 | not (isLocalId v) && isCheapUnfolding unf
1706 = isValue env (unfoldingTemplate unf)
1709 -- However we do want to consult the unfolding
1710 -- as well, for let-bound constructors!
1712 isValue env (Lam b e)
1713 | isTyVar b = case isValue env e of
1714 Just _ -> Just LambdaVal
1716 | otherwise = Just LambdaVal
1718 isValue _env expr -- Maybe it's a constructor application
1719 | (Var fun, args) <- collectArgs expr
1720 = case isDataConWorkId_maybe fun of
1722 Just con | args `lengthAtLeast` dataConRepArity con
1723 -- Check saturated; might be > because the
1724 -- arity excludes type args
1725 -> Just (ConVal (DataAlt con) args)
1727 _other | valArgCount args < idArity fun
1728 -- Under-applied function
1729 -> Just LambdaVal -- Partial application
1733 isValue _env _expr = Nothing
1735 samePat :: CallPat -> CallPat -> Bool
1736 samePat (vs1, as1) (vs2, as2)
1739 same (Var v1) (Var v2)
1740 | v1 `elem` vs1 = v2 `elem` vs2
1741 | v2 `elem` vs2 = False
1742 | otherwise = v1 == v2
1744 same (Lit l1) (Lit l2) = l1==l2
1745 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1747 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1748 same (Coercion {}) (Coercion {}) = True
1749 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1750 same (Cast e1 _) e2 = same e1 e2
1751 same e1 (Note _ e2) = same e1 e2
1752 same e1 (Cast e2 _) = same e1 e2
1754 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1755 False -- Let, lambda, case should not occur
1756 bad (Case {}) = True
1762 Note [Ignore type differences]
1763 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1764 We do not want to generate specialisations where the call patterns
1765 differ only in their type arguments! Not only is it utterly useless,
1766 but it also means that (with polymorphic recursion) we can generate
1767 an infinite number of specialisations. Example is Data.Sequence.adjustTree,