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 )
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 )
58 import Control.Monad ( zipWithM )
62 -- See Note [SpecConstrAnnotation]
64 type SpecConstrAnnotation = ()
66 import TyCon ( TyCon )
67 import GHC.Exts( SpecConstrAnnotation(..) )
71 -----------------------------------------------------
73 -----------------------------------------------------
78 drop n (x:xs) = drop (n-1) xs
80 After the first time round, we could pass n unboxed. This happens in
81 numerical code too. Here's what it looks like in Core:
83 drop n xs = case xs of
88 _ -> drop (I# (n# -# 1#)) xs
90 Notice that the recursive call has an explicit constructor as argument.
91 Noticing this, we can make a specialised version of drop
93 RULE: drop (I# n#) xs ==> drop' n# xs
95 drop' n# xs = let n = I# n# in ...orig RHS...
97 Now the simplifier will apply the specialisation in the rhs of drop', giving
99 drop' n# xs = case xs of
103 _ -> drop (n# -# 1#) xs
107 We'd also like to catch cases where a parameter is carried along unchanged,
108 but evaluated each time round the loop:
110 f i n = if i>0 || i>n then i else f (i*2) n
112 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
113 In Core, by the time we've w/wd (f is strict in i) we get
115 f i# n = case i# ># 0 of
117 True -> case n of n' { I# n# ->
120 True -> f (i# *# 2#) n'
122 At the call to f, we see that the argument, n is know to be (I# n#),
123 and n is evaluated elsewhere in the body of f, so we can play the same
129 We must be careful not to allocate the same constructor twice. Consider
130 f p = (...(case p of (a,b) -> e)...p...,
131 ...let t = (r,s) in ...t...(f t)...)
132 At the recursive call to f, we can see that t is a pair. But we do NOT want
133 to make a specialised copy:
134 f' a b = let p = (a,b) in (..., ...)
135 because now t is allocated by the caller, then r and s are passed to the
136 recursive call, which allocates the (r,s) pair again.
139 (a) the argument p is used in other than a case-scrutinsation way.
140 (b) the argument to the call is not a 'fresh' tuple; you have to
141 look into its unfolding to see that it's a tuple
143 Hence the "OR" part of Note [Good arguments] below.
145 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
146 allocation, but does perhaps save evals. In the RULE we'd have
149 f (I# x#) = f' (I# x#) x#
151 If at the call site the (I# x) was an unfolding, then we'd have to
152 rely on CSE to eliminate the duplicate allocation.... This alternative
153 doesn't look attractive enough to pursue.
155 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
156 the conservative reboxing story prevents many useful functions from being
157 specialised. Example:
158 foo :: Maybe Int -> Int -> Int
160 foo x@(Just m) n = foo x (n-m)
161 Here the use of 'x' will clearly not require boxing in the specialised function.
163 The strictness analyser has the same problem, in fact. Example:
165 If we pass just 'a' and 'b' to the worker, it might need to rebox the
166 pair to create (a,b). A more sophisticated analysis might figure out
167 precisely the cases in which this could happen, but the strictness
168 analyser does no such analysis; it just passes 'a' and 'b', and hopes
171 So my current choice is to make SpecConstr similarly aggressive, and
172 ignore the bad potential of reboxing.
175 Note [Good arguments]
176 ~~~~~~~~~~~~~~~~~~~~~
179 * A self-recursive function. Ignore mutual recursion for now,
180 because it's less common, and the code is simpler for self-recursion.
184 a) At a recursive call, one or more parameters is an explicit
185 constructor application
187 That same parameter is scrutinised by a case somewhere in
188 the RHS of the function
192 b) At a recursive call, one or more parameters has an unfolding
193 that is an explicit constructor application
195 That same parameter is scrutinised by a case somewhere in
196 the RHS of the function
198 Those are the only uses of the parameter (see Note [Reboxing])
201 What to abstract over
202 ~~~~~~~~~~~~~~~~~~~~~
203 There's a bit of a complication with type arguments. If the call
206 f p = ...f ((:) [a] x xs)...
208 then our specialised function look like
210 f_spec x xs = let p = (:) [a] x xs in ....as before....
212 This only makes sense if either
213 a) the type variable 'a' is in scope at the top of f, or
214 b) the type variable 'a' is an argument to f (and hence fs)
216 Actually, (a) may hold for value arguments too, in which case
217 we may not want to pass them. Supose 'x' is in scope at f's
218 defn, but xs is not. Then we'd like
220 f_spec xs = let p = (:) [a] x xs in ....as before....
222 Similarly (b) may hold too. If x is already an argument at the
223 call, no need to pass it again.
225 Finally, if 'a' is not in scope at the call site, we could abstract
226 it as we do the term variables:
228 f_spec a x xs = let p = (:) [a] x xs in ...as before...
230 So the grand plan is:
232 * abstract the call site to a constructor-only pattern
233 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
235 * Find the free variables of the abstracted pattern
237 * Pass these variables, less any that are in scope at
238 the fn defn. But see Note [Shadowing] below.
241 NOTICE that we only abstract over variables that are not in scope,
242 so we're in no danger of shadowing variables used in "higher up"
248 In this pass we gather up usage information that may mention variables
249 that are bound between the usage site and the definition site; or (more
250 seriously) may be bound to something different at the definition site.
253 f x = letrec g y v = let x = ...
256 Since 'x' is in scope at the call site, we may make a rewrite rule that
258 RULE forall a,b. g (a,b) x = ...
259 But this rule will never match, because it's really a different 'x' at
260 the call site -- and that difference will be manifest by the time the
261 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
262 no-shadowing, so perhaps it may not be distinct?]
264 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
265 is to run deShadowBinds before running SpecConstr, but instead we run the
266 simplifier. That gives the simplest possible program for SpecConstr to
267 chew on; and it virtually guarantees no shadowing.
269 Note [Specialising for constant parameters]
270 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
271 This one is about specialising on a *constant* (but not necessarily
272 constructor) argument
274 foo :: Int -> (Int -> Int) -> Int
276 foo m f = foo (f m) (+1)
280 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
282 \ (ds_dlk :: GHC.Base.Int) ->
283 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
284 GHC.Base.I# (GHC.Prim.+# x_alG 1)
286 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
289 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
290 case ww_sme of ds_Xlw {
292 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
293 T.$wfoo ww1_Xmz lvl_rmV
298 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
299 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
301 When is this worth it? Call the constant 'lvl'
302 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
303 parameter is scrutinised anywhere in the body.
305 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
306 parameter is applied (...to enough arguments...?)
308 Also do this is if the function has RULES?
312 Note [Specialising for lambda parameters]
313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
314 foo :: Int -> (Int -> Int) -> Int
316 foo m f = foo (f m) (\n -> n-m)
318 This is subtly different from the previous one in that we get an
319 explicit lambda as the argument:
321 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
324 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
325 case ww_sm8 of ds_Xlr {
327 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
330 (\ (n_ad3 :: GHC.Base.Int) ->
331 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
332 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
338 I wonder if SpecConstr couldn't be extended to handle this? After all,
339 lambda is a sort of constructor for functions and perhaps it already
340 has most of the necessary machinery?
342 Furthermore, there's an immediate win, because you don't need to allocate the lamda
343 at the call site; and if perchance it's called in the recursive call, then you
344 may avoid allocating it altogether. Just like for constructors.
346 Looks cool, but probably rare...but it might be easy to implement.
349 Note [SpecConstr for casts]
350 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
353 data instance T Int = T Int
358 go (T n) = go (T (n-1))
360 The recursive call ends up looking like
361 go (T (I# ...) `cast` g)
362 So we want to spot the construtor application inside the cast.
363 That's why we have the Cast case in argToPat
365 Note [Local recursive groups]
366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
367 For a *local* recursive group, we can see all the calls to the
368 function, so we seed the specialisation loop from the calls in the
369 body, not from the calls in the RHS. Consider:
371 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
375 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
376 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
377 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
378 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
380 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
381 most of which are not needed. But if we start with the (single) call
382 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
383 the recursive calls go to this fully-specialised copy. Indeed, the original
384 function is later collected as dead code. This is very important in
385 specialising the loops arising from stream fusion, for example in NDP where
386 we were getting literally hundreds of (mostly unused) specialisations of
389 In a case like the above we end up never calling the original un-specialised
390 function. (Although we still leave its code around just in case.)
392 However, if we find any boring calls in the body, including *unsaturated*
394 letrec foo x y = ....foo...
396 then we will end up calling the un-specialised function, so then we *should*
397 use the calls in the un-specialised RHS as seeds. We call these "boring
398 call patterns, and callsToPats reports if it finds any of these.
401 Note [Do not specialise diverging functions]
402 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
403 Specialising a function that just diverges is a waste of code.
404 Furthermore, it broke GHC (simpl014) thus:
406 f = \x. case x of (a,b) -> f x
407 If we specialise f we get
408 f = \x. case x of (a,b) -> fspec a b
409 But fspec doesn't have decent strictnes info. As it happened,
410 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
411 and hence f. But now f's strictness is less than its arity, which
414 Note [SpecConstrAnnotation]
415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
416 SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
417 be available in stage 2 (well, until the bootstrap compiler can be
418 guaranteed to have it)
420 So we define it to be () in stage1 (ie when GHCI is undefined), and
421 '#ifdef' out the code that uses it.
423 See also Note [Forcing specialisation]
425 Note [Forcing specialisation]
426 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
427 With stream fusion and in other similar cases, we want to fully specialise
428 some (but not necessarily all!) loops regardless of their size and the
429 number of specialisations. We allow a library to specify this by annotating
430 a type with ForceSpecConstr and then adding a parameter of that type to the
431 loop. Here is a (simplified) example from the vector library:
433 data SPEC = SPEC | SPEC2
434 {-# ANN type SPEC ForceSpecConstr #-}
436 foldl :: (a -> b -> a) -> a -> Stream b -> a
438 foldl f z (Stream step s _) = foldl_loop SPEC z s
440 foldl_loop !sPEC z s = case step s of
441 Yield x s' -> foldl_loop sPEC (f z x) s'
442 Skip -> foldl_loop sPEC z s'
445 SpecConstr will spot the SPEC parameter and always fully specialise
446 foldl_loop. Note that
448 * We have to prevent the SPEC argument from being removed by
449 w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
452 * And lastly, the SPEC argument is ultimately eliminated by
453 SpecConstr itself so there is no runtime overhead.
455 This is all quite ugly; we ought to come up with a better design.
457 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
458 sc_force to True when calling specLoop. This flag does three things:
459 * Ignore specConstrThreshold, to specialise functions of arbitrary size
461 * Ignore specConstrCount, to make arbitrary numbers of specialisations
463 * Specialise even for arguments that are not scrutinised in the loop
464 (see argToPat; Trac #4488)
466 This flag is inherited for nested non-recursive bindings (which are likely to
467 be join points and hence should be fully specialised) but reset for nested
470 What alternatives did I consider? Annotating the loop itself doesn't
471 work because (a) it is local and (b) it will be w/w'ed and I having
472 w/w propagating annotation somehow doesn't seem like a good idea. The
473 types of the loop arguments really seem to be the most persistent
476 Annotating the types that make up the loop state doesn't work,
477 either, because (a) it would prevent us from using types like Either
478 or tuples here, (b) we don't want to restrict the set of types that
479 can be used in Stream states and (c) some types are fixed by the user
480 (e.g., the accumulator here) but we still want to specialise as much
483 ForceSpecConstr is done by way of an annotation:
484 data SPEC = SPEC | SPEC2
485 {-# ANN type SPEC ForceSpecConstr #-}
486 But SPEC is the *only* type so annotated, so it'd be better to
487 use a particular library type.
489 Alternatives to ForceSpecConstr
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491 Instead of giving the loop an extra argument of type SPEC, we
492 also considered *wrapping* arguments in SPEC, thus
493 data SPEC a = SPEC a | SPEC2
495 loop = \arg -> case arg of
497 case state of (x,y) -> ... loop (SPEC (x',y')) ...
499 The idea is that a SPEC argument says "specialise this argument
500 regardless of whether the function case-analyses it. But this
502 * SPEC must still be a sum type, else the strictness analyser
504 * But that means that 'loop' won't be strict in its real payload
505 This loss of strictness in turn screws up specialisation, because
506 we may end up with calls like
507 loop (SPEC (case z of (p,q) -> (q,p)))
508 Without the SPEC, if 'loop' was strict, the case would move out
509 and we'd see loop applied to a pair. But if 'loop' isn' strict
510 this doesn't look like a specialisable call.
514 The ignoreDataCon stuff allows you to say
515 {-# ANN type T NoSpecConstr #-}
516 to mean "don't specialise on arguments of this type. It was added
517 before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised
518 regardless of size; and then we needed a way to turn that *off*. Now
519 that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
520 (Used only for PArray.)
522 -----------------------------------------------------
523 Stuff not yet handled
524 -----------------------------------------------------
526 Here are notes arising from Roman's work that I don't want to lose.
532 foo :: Int -> T Int -> Int
534 foo x t | even x = case t of { T n -> foo (x-n) t }
535 | otherwise = foo (x-1) t
537 SpecConstr does no specialisation, because the second recursive call
538 looks like a boxed use of the argument. A pity.
540 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
542 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
543 case ww_sFo of ds_Xw6 [Just L] {
545 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
546 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
548 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
549 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
550 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
556 data a :*: b = !a :*: !b
559 foo :: (Int :*: T Int) -> Int
561 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
562 | otherwise = foo ((x-1) :*: t)
564 Very similar to the previous one, except that the parameters are now in
565 a strict tuple. Before SpecConstr, we have
567 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
569 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
571 case ww_sFU of ds_Xws [Just L] {
573 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
575 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
576 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
579 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
580 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
581 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
585 We get two specialisations:
586 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
587 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
588 = Foo.$s$wfoo1 a_sFB sc_sGC ;
589 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
590 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
591 = Foo.$s$wfoo y_aFp sc_sGC ;
593 But perhaps the first one isn't good. After all, we know that tpl_B2 is
594 a T (I# x) really, because T is strict and Int has one constructor. (We can't
595 unbox the strict fields, becuase T is polymorphic!)
597 %************************************************************************
599 \subsection{Top level wrapper stuff}
601 %************************************************************************
604 specConstrProgram :: ModGuts -> CoreM ModGuts
605 specConstrProgram guts
607 dflags <- getDynFlags
608 us <- getUniqueSupplyM
609 annos <- getFirstAnnotations deserializeWithData guts
610 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
611 return (guts { mg_binds = binds' })
614 go env (bind:binds) = do (env', bind') <- scTopBind env bind
615 binds' <- go env' binds
616 return (bind' : binds')
620 %************************************************************************
622 \subsection{Environment: goes downwards}
624 %************************************************************************
627 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
628 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
629 -- See Note [Avoiding exponential blowup]
630 sc_force :: Bool, -- Force specialisation?
631 -- See Note [Forcing specialisation]
633 sc_subst :: Subst, -- Current substitution
634 -- Maps InIds to OutExprs
636 sc_how_bound :: HowBoundEnv,
637 -- Binds interesting non-top-level variables
638 -- Domain is OutVars (*after* applying the substitution)
641 -- Domain is OutIds (*after* applying the substitution)
642 -- Used even for top-level bindings (but not imported ones)
644 sc_annotations :: UniqFM SpecConstrAnnotation
647 ---------------------
648 -- As we go, we apply a substitution (sc_subst) to the current term
649 type InExpr = CoreExpr -- _Before_ applying the subst
652 type OutExpr = CoreExpr -- _After_ applying the subst
656 ---------------------
657 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
659 ---------------------
660 type ValueEnv = IdEnv Value -- Domain is OutIds
661 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
662 -- The AltCon is never DEFAULT
663 | LambdaVal -- Inlinable lambdas or PAPs
665 instance Outputable Value where
666 ppr (ConVal con args) = ppr con <+> interpp'SP args
667 ppr LambdaVal = ptext (sLit "<Lambda>")
669 ---------------------
670 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
671 initScEnv dflags anns
672 = SCE { sc_size = specConstrThreshold dflags,
673 sc_count = specConstrCount dflags,
675 sc_subst = emptySubst,
676 sc_how_bound = emptyVarEnv,
677 sc_vals = emptyVarEnv,
678 sc_annotations = anns }
680 data HowBound = RecFun -- These are the recursive functions for which
681 -- we seek interesting call patterns
683 | RecArg -- These are those functions' arguments, or their sub-components;
684 -- we gather occurrence information for these
686 instance Outputable HowBound where
687 ppr RecFun = text "RecFun"
688 ppr RecArg = text "RecArg"
690 scForce :: ScEnv -> Bool -> ScEnv
691 scForce env b = env { sc_force = b }
693 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
694 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
696 scSubstId :: ScEnv -> Id -> CoreExpr
697 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
699 scSubstTy :: ScEnv -> Type -> Type
700 scSubstTy env ty = substTy (sc_subst env) ty
702 zapScSubst :: ScEnv -> ScEnv
703 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
705 extendScInScope :: ScEnv -> [Var] -> ScEnv
706 -- Bring the quantified variables into scope
707 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
709 -- Extend the substitution
710 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
711 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
713 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
714 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
716 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
717 extendHowBound env bndrs how_bound
718 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
719 [(bndr,how_bound) | bndr <- bndrs] }
721 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
722 extendBndrsWith how_bound env bndrs
723 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
725 (subst', bndrs') = substBndrs (sc_subst env) bndrs
726 hb_env' = sc_how_bound env `extendVarEnvList`
727 [(bndr,how_bound) | bndr <- bndrs']
729 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
730 extendBndrWith how_bound env bndr
731 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
733 (subst', bndr') = substBndr (sc_subst env) bndr
734 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
736 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
737 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
739 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
741 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
742 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
744 (subst', bndr') = substBndr (sc_subst env) bndr
746 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
747 extendValEnv env _ Nothing = env
748 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
750 extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
754 -- we want to bind b, to (C x y)
755 -- NB1: Extends only the sc_vals part of the envt
756 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
757 -- they are potentially made alive by the [b -> C x y] binding
758 extendCaseBndrs env scrut case_bndr con alt_bndrs
761 live_case_bndr = not (isDeadBinder case_bndr)
762 env1 | Var v <- scrut = extendValEnv env v cval
763 | otherwise = env -- See Note [Add scrutinee to ValueEnv too]
764 env2 | live_case_bndr = extendValEnv env1 case_bndr cval
767 alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
774 LitAlt {} -> Just (ConVal con [])
775 DataAlt {} -> Just (ConVal con vanilla_args)
777 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
778 varsToCoreExprs alt_bndrs
780 zap v | isTyCoVar v = v -- See NB2 above
781 | otherwise = zapIdOccInfo v
784 decreaseSpecCount :: ScEnv -> Int -> ScEnv
785 -- See Note [Avoiding exponential blowup]
786 decreaseSpecCount env n_specs
787 = env { sc_count = case sc_count env of
789 Just n -> Just (n `div` (n_specs + 1)) }
790 -- The "+1" takes account of the original function;
791 -- See Note [Avoiding exponential blowup]
793 ---------------------------------------------------
794 -- See Note [SpecConstrAnnotation]
795 ignoreType :: ScEnv -> Type -> Bool
796 ignoreDataCon :: ScEnv -> DataCon -> Bool
797 forceSpecBndr :: ScEnv -> Var -> Bool
799 ignoreType _ _ = False
800 ignoreDataCon _ _ = False
801 forceSpecBndr _ _ = False
805 ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
808 = case splitTyConApp_maybe ty of
809 Just (tycon, _) -> ignoreTyCon env tycon
812 ignoreTyCon :: ScEnv -> TyCon -> Bool
813 ignoreTyCon env tycon
814 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
816 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
818 forceSpecFunTy :: ScEnv -> Type -> Bool
819 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
821 forceSpecArgTy :: ScEnv -> Type -> Bool
822 forceSpecArgTy env ty
823 | Just ty' <- coreView ty = forceSpecArgTy env ty'
825 forceSpecArgTy env ty
826 | Just (tycon, tys) <- splitTyConApp_maybe ty
828 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
829 || any (forceSpecArgTy env) tys
831 forceSpecArgTy _ _ = False
835 Note [Add scrutinee to ValueEnv too]
836 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
841 By the time we get to the call (f y), the ValueEnv
842 will have a binding for y, and for c
845 BUT that's not enough! Looking at the call (f y) we
846 see that y is pair (a,b), but we also need to know what 'b' is.
847 So in extendCaseBndrs we must *also* add the binding
849 else we lose a useful specialisation for f. This is necessary even
850 though the simplifier has systematically replaced uses of 'x' with 'y'
851 and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came
852 from outside the case. See Trac #4908 for the live example.
854 Note [Avoiding exponential blowup]
855 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
856 The sc_count field of the ScEnv says how many times we are prepared to
857 duplicate a single function. But we must take care with recursive
858 specialiations. Consider
860 let $j1 = let $j2 = let $j3 = ...
868 If we specialise $j1 then in each specialisation (as well as the original)
869 we can specialise $j2, and similarly $j3. Even if we make just *one*
870 specialisation of each, becuase we also have the original we'll get 2^n
871 copies of $j3, which is not good.
873 So when recursively specialising we divide the sc_count by the number of
874 copies we are making at this level, including the original.
877 %************************************************************************
879 \subsection{Usage information: flows upwards}
881 %************************************************************************
886 scu_calls :: CallEnv, -- Calls
887 -- The functions are a subset of the
888 -- RecFuns in the ScEnv
890 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
891 } -- The domain is OutIds
893 type CallEnv = IdEnv [Call]
894 type Call = (ValueEnv, [CoreArg])
895 -- The arguments of the call, together with the
896 -- env giving the constructor bindings at the call site
899 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
901 combineCalls :: CallEnv -> CallEnv -> CallEnv
902 combineCalls = plusVarEnv_C (++)
904 combineUsage :: ScUsage -> ScUsage -> ScUsage
905 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
906 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
908 combineUsages :: [ScUsage] -> ScUsage
909 combineUsages [] = nullUsage
910 combineUsages us = foldr1 combineUsage us
912 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
913 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
914 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
915 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
917 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
918 | UnkOcc -- Used in some unknown way
920 | ScrutOcc -- See Note [ScrutOcc]
921 (DataConEnv [ArgOcc]) -- How the sub-components are used
923 type DataConEnv a = UniqFM a -- Keyed by DataCon
927 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
928 is *only* taken apart or applied.
930 Functions, literal: ScrutOcc emptyUFM
931 Data constructors: ScrutOcc subs,
933 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
934 The domain of the UniqFM is the Unique of the data constructor
936 The [ArgOcc] is the occurrences of the *pattern-bound* components
937 of the data structure. E.g.
938 data T a = forall b. MkT a b (b->a)
939 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
943 instance Outputable ArgOcc where
944 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
945 ppr UnkOcc = ptext (sLit "unk-occ")
946 ppr NoOcc = ptext (sLit "no-occ")
948 evalScrutOcc :: ArgOcc
949 evalScrutOcc = ScrutOcc emptyUFM
951 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
952 -- that if the thing is scrutinised anywhere then we get to see that
953 -- in the overall result, even if it's also used in a boxed way
954 -- This might be too agressive; see Note [Reboxing] Alternative 3
955 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
956 combineOcc NoOcc occ = occ
957 combineOcc occ NoOcc = occ
958 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
959 combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys
960 combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs
961 combineOcc UnkOcc UnkOcc = UnkOcc
963 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
964 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
966 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
967 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
968 -- is a variable, and an interesting variable
969 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
970 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
971 setScrutOcc env usg (Var v) occ
972 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
974 setScrutOcc _env usg _other _occ -- Catch-all
978 %************************************************************************
980 \subsection{The main recursive function}
982 %************************************************************************
984 The main recursive function gathers up usage information, and
985 creates specialised versions of functions.
988 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
989 -- The unique supply is needed when we invent
990 -- a new name for the specialised function and its args
992 scExpr env e = scExpr' env e
995 scExpr' env (Var v) = case scSubstId env v of
996 Var v' -> return (mkVarUsage env v' [], Var v')
997 e' -> scExpr (zapScSubst env) e'
999 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
1000 scExpr' _ e@(Lit {}) = return (nullUsage, e)
1001 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
1002 return (usg, Note n e')
1003 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
1004 return (usg, Cast e' (scSubstTy env co))
1005 scExpr' env e@(App _ _) = scApp env (collectArgs e)
1006 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
1007 (usg, e') <- scExpr env' e
1008 return (usg, Lam b' e')
1010 scExpr' env (Case scrut b ty alts)
1011 = do { (scrut_usg, scrut') <- scExpr env scrut
1012 ; case isValue (sc_vals env) scrut' of
1013 Just (ConVal con args) -> sc_con_app con args scrut'
1014 _other -> sc_vanilla scrut_usg scrut'
1017 sc_con_app con args scrut' -- Known constructor; simplify
1018 = do { let (_, bs, rhs) = findAlt con alts
1019 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
1020 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
1021 ; scExpr alt_env' rhs }
1023 sc_vanilla scrut_usg scrut' -- Normal case
1024 = do { let (alt_env,b') = extendBndrWith RecArg env b
1025 -- Record RecArg for the components
1027 ; (alt_usgs, alt_occs, alts')
1028 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
1030 ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty
1031 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
1032 -- The combined usage of the scrutinee is given
1033 -- by scrut_occ, which is passed to scScrut, which
1034 -- in turn treats a bare-variable scrutinee specially
1036 ; return (foldr combineUsage scrut_usg' alt_usgs,
1037 Case scrut' b' (scSubstTy env ty) alts') }
1039 sc_alt env scrut' b' (con,bs,rhs)
1040 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
1041 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
1042 ; (usg, rhs') <- scExpr env2 rhs
1043 ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
1044 scrut_occ = case con of
1045 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
1046 _ -> ScrutOcc emptyUFM
1047 ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
1049 scExpr' env (Let (NonRec bndr rhs) body)
1050 | isTyCoVar bndr -- Type-lets may be created by doBeta
1051 = scExpr' (extendScSubst env bndr rhs) body
1054 = do { let (body_env, bndr') = extendBndr env bndr
1055 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
1057 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
1058 -- Note [Local let bindings]
1059 RI _ rhs' _ _ _ = rhs_info
1060 body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
1062 ; (body_usg, body') <- scExpr body_env3 body
1064 -- NB: For non-recursive bindings we inherit sc_force flag from
1065 -- the parent function (see Note [Forcing specialisation])
1066 ; (spec_usg, specs) <- specialise env
1067 (scu_calls body_usg)
1069 (SI [] 0 (Just rhs_usg))
1071 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1072 `combineUsage` rhs_usg `combineUsage` spec_usg,
1073 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1077 -- A *local* recursive group: see Note [Local recursive groups]
1078 scExpr' env (Let (Rec prs) body)
1079 = do { let (bndrs,rhss) = unzip prs
1080 (rhs_env1,bndrs') = extendRecBndrs env bndrs
1081 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1082 force_spec = any (forceSpecBndr env) bndrs'
1083 -- Note [Forcing specialisation]
1085 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1086 ; (body_usg, body') <- scExpr rhs_env2 body
1088 -- NB: start specLoop from body_usg
1089 ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
1090 (scu_calls body_usg) rhs_infos nullUsage
1091 [SI [] 0 (Just usg) | usg <- rhs_usgs]
1092 -- Do not unconditionally generate specialisations from rhs_usgs
1093 -- Instead use them only if we find an unspecialised call
1094 -- See Note [Local recursive groups]
1096 ; let rhs_usg = combineUsages rhs_usgs
1097 all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg
1098 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1100 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1104 Note [Local let bindings]
1105 ~~~~~~~~~~~~~~~~~~~~~~~~~
1106 It is not uncommon to find this
1108 let $j = \x. <blah> in ...$j True...$j True...
1110 Here $j is an arbitrary let-bound function, but it often comes up for
1111 join points. We might like to specialise $j for its call patterns.
1112 Notice the difference from a letrec, where we look for call patterns
1113 in the *RHS* of the function. Here we look for call patterns in the
1116 At one point I predicated this on the RHS mentioning the outer
1117 recursive function, but that's not essential and might even be
1118 harmful. I'm not sure.
1122 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1124 scApp env (Var fn, args) -- Function is a variable
1125 = ASSERT( not (null args) )
1126 do { args_w_usgs <- mapM (scExpr env) args
1127 ; let (arg_usgs, args') = unzip args_w_usgs
1128 arg_usg = combineUsages arg_usgs
1129 ; case scSubstId env fn of
1130 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1131 -- Do beta-reduction and try again
1133 Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
1134 mkApps (Var fn') args')
1136 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1137 -- NB: doing this ignores any usage info from the substituted
1138 -- function, but I don't think that matters. If it does
1141 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1142 -- ToDo: adjust for System IF
1143 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1144 doBeta fn args = mkApps fn args
1146 -- The function is almost always a variable, but not always.
1147 -- In particular, if this pass follows float-in,
1148 -- which it may, we can get
1149 -- (let f = ...f... in f) arg1 arg2
1150 scApp env (other_fn, args)
1151 = do { (fn_usg, fn') <- scExpr env other_fn
1152 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1153 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1155 ----------------------
1156 mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
1157 mkVarUsage env fn args
1158 = case lookupHowBound env fn of
1159 Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)]
1160 , scu_occs = emptyVarEnv }
1161 Just RecArg -> SCU { scu_calls = emptyVarEnv
1162 , scu_occs = unitVarEnv fn arg_occ }
1163 Nothing -> nullUsage
1165 -- I rather think we could use UnkOcc all the time
1166 arg_occ | null args = UnkOcc
1167 | otherwise = evalScrutOcc
1169 ----------------------
1170 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1171 scTopBind env (Rec prs)
1172 | Just threshold <- sc_size env
1174 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1175 -- No specialisation
1176 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1177 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1178 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1179 | otherwise -- Do specialisation
1180 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1181 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1183 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1184 ; let rhs_usg = combineUsages rhs_usgs
1186 ; (_, specs) <- specLoop (scForce rhs_env2 force_spec)
1187 (scu_calls rhs_usg) rhs_infos nullUsage
1188 [SI [] 0 Nothing | _ <- bndrs]
1190 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1191 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1193 (bndrs,rhss) = unzip prs
1194 force_spec = any (forceSpecBndr env) bndrs
1195 -- Note [Forcing specialisation]
1197 scTopBind env (NonRec bndr rhs)
1198 = do { (_, rhs') <- scExpr env rhs
1199 ; let (env1, bndr') = extendBndr env bndr
1200 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1201 ; return (env2, NonRec bndr' rhs') }
1203 ----------------------
1204 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1205 scRecRhs env (bndr,rhs)
1206 = do { let (arg_bndrs,body) = collectBinders rhs
1207 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1208 ; (body_usg, body') <- scExpr body_env body
1209 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1210 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1211 arg_bndrs body arg_occs) }
1212 -- The arg_occs says how the visible,
1213 -- lambda-bound binders of the RHS are used
1214 -- (including the TyVar binders)
1215 -- Two pats are the same if they match both ways
1217 ----------------------
1218 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1219 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1220 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1221 -- First the specialised bindings
1223 [(fn `addIdSpecialisations` rules, new_rhs)]
1224 -- And now the original binding
1226 rules = [r | OS _ r _ _ <- specs]
1230 %************************************************************************
1232 The specialiser itself
1234 %************************************************************************
1237 data RhsInfo = RI OutId -- The binder
1238 OutExpr -- The new RHS
1239 [InVar] InExpr -- The *original* RHS (\xs.body)
1240 -- Note [Specialise original body]
1241 [ArgOcc] -- Info on how the xs occur in body
1243 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1245 Int -- Length of specs; used for numbering them
1247 (Maybe ScUsage) -- Just cs => we have not yet used calls in the
1248 -- from calls in the *original* RHS as
1249 -- seeds for new specialisations;
1250 -- if you decide to do so, here is the
1251 -- RHS usage (which has not yet been
1253 -- Nothing => we have
1254 -- See Note [Local recursive groups]
1256 -- One specialisation: Rule plus definition
1257 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1258 CoreRule -- Rule connecting original id with the specialisation
1259 OutId OutExpr -- Spec id + its rhs
1265 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1266 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1268 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1269 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1270 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1271 new_usg = combineUsages new_usg_s
1272 new_calls = scu_calls new_usg
1273 all_usg = usg_so_far `combineUsage` new_usg
1274 ; if isEmptyVarEnv new_calls then
1275 return (all_usg, all_specs)
1277 specLoop env new_calls rhs_infos all_usg all_specs }
1281 -> CallEnv -- Info on calls
1283 -> SpecInfo -- Original RHS plus patterns dealt with
1284 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1286 -- Note: this only generates *specialised* bindings
1287 -- The original binding is added by specInfoBinds
1289 -- Note: the rhs here is the optimised version of the original rhs
1290 -- So when we make a specialised copy of the RHS, we're starting
1291 -- from an RHS whose nested functions have been optimised already.
1293 specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
1294 spec_info@(SI specs spec_count mb_unspec)
1295 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1296 , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1297 , notNull arg_bndrs -- Only specialise functions
1298 , Just all_calls <- lookupVarEnv bind_calls fn
1299 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1300 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1301 -- , text "arg_occs" <+> ppr arg_occs
1302 -- , text "calls" <+> ppr all_calls
1303 -- , text "good pats" <+> ppr pats]) $
1306 -- Bale out if too many specialisations
1307 ; let n_pats = length pats
1308 spec_count' = n_pats + spec_count
1309 ; case sc_count env of
1310 Just max | not (sc_force env) && spec_count' > max
1311 -> pprTrace "SpecConstr" msg $
1312 return (nullUsage, spec_info)
1314 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1315 , nest 2 (ptext (sLit "has") <+>
1316 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1317 ptext (sLit "but the limit is") <+> int max) ]
1318 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1320 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1321 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1323 _normal_case -> do {
1325 let spec_env = decreaseSpecCount env n_pats
1326 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1327 (pats `zip` [spec_count..])
1328 -- See Note [Specialise original body]
1330 ; let spec_usg = combineUsages spec_usgs
1331 (new_usg, mb_unspec')
1333 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1334 _ -> (spec_usg, mb_unspec)
1336 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1338 = return (nullUsage, spec_info) -- The boring case
1341 ---------------------
1343 -> OutId -- Function
1344 -> [InVar] -- Lambda-binders of RHS; should match patterns
1345 -> InExpr -- Body of the original function
1347 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1349 -- spec_one creates a specialised copy of the function, together
1350 -- with a rule for using it. I'm very proud of how short this
1351 -- function is, considering what it does :-).
1357 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1358 [c::*, v::(b,c) are presumably bound by the (...) part]
1360 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1361 (...entire body of f...) [b -> (b,c),
1362 y -> ((:) (a,(b,c)) (x,v) hw)]
1364 RULE: forall b::* c::*, -- Note, *not* forall a, x
1368 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1371 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1372 = do { spec_uniq <- getUniqueUs
1373 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1374 (arg_bndrs `zip` pats)
1376 fn_loc = nameSrcSpan fn_name
1377 spec_occ = mkSpecOcc (nameOccName fn_name)
1378 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1379 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1380 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1383 -- Specialise the body
1384 ; (spec_usg, spec_body) <- scExpr spec_env body
1386 -- ; pprTrace "done spec_one}" (ppr fn) $
1389 -- And build the results
1390 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1391 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1392 `setIdArity` count isId spec_lam_args
1393 spec_str = calcSpecStrictness fn spec_lam_args pats
1394 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1395 -- Usual w/w hack to avoid generating
1396 -- a spec_rhs of unlifted type and no args
1398 spec_rhs = mkLams spec_lam_args spec_body
1399 body_ty = exprType spec_body
1400 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1401 inline_act = idInlineActivation fn
1402 rule = mkRule True {- Auto -} True {- Local -}
1403 rule_name inline_act fn_name qvars pats rule_rhs
1404 -- See Note [Transfer activation]
1405 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1407 calcSpecStrictness :: Id -- The original function
1408 -> [Var] -> [CoreExpr] -- Call pattern
1409 -> StrictSig -- Strictness of specialised thing
1410 -- See Note [Transfer strictness]
1411 calcSpecStrictness fn qvars pats
1412 = StrictSig (mkTopDmdType spec_dmds TopRes)
1414 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1415 StrictSig (DmdType _ dmds _) = idStrictness fn
1417 dmd_env = go emptyVarEnv dmds pats
1419 go env ds (Type {} : pats) = go env ds pats
1420 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1423 go_one env d (Var v) = extendVarEnv_C both env v d
1424 go_one env (Box d) e = go_one env d e
1425 go_one env (Eval (Prod ds)) e
1426 | (Var _, args) <- collectArgs e = go env ds args
1427 go_one env _ _ = env
1431 Note [Specialise original body]
1432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1433 The RhsInfo for a binding keeps the *original* body of the binding. We
1434 must specialise that, *not* the result of applying specExpr to the RHS
1435 (which is also kept in RhsInfo). Otherwise we end up specialising a
1436 specialised RHS, and that can lead directly to exponential behaviour.
1438 Note [Transfer activation]
1439 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1440 This note is for SpecConstr, but exactly the same thing
1441 happens in the overloading specialiser; see
1442 Note [Auto-specialisation and RULES] in Specialise.
1444 In which phase should the specialise-constructor rules be active?
1445 Originally I made them always-active, but Manuel found that this
1446 defeated some clever user-written rules. Then I made them active only
1447 in Phase 0; after all, currently, the specConstr transformation is
1448 only run after the simplifier has reached Phase 0, but that meant
1449 that specialisations didn't fire inside wrappers; see test
1450 simplCore/should_compile/spec-inline.
1452 So now I just use the inline-activation of the parent Id, as the
1453 activation for the specialiation RULE, just like the main specialiser;
1455 This in turn means there is no point in specialising NOINLINE things,
1456 so we test for that.
1458 Note [Transfer strictness]
1459 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1460 We must transfer strictness information from the original function to
1461 the specialised one. Suppose, for example
1464 and a RULE f (a:as) b = f_spec a as b
1466 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1467 when calling f_spec instead of call-by-value. And that can result in
1468 unbounded worsening in space (cf the classic foldl vs foldl')
1470 See Trac #3437 for a good example.
1472 The function calcSpecStrictness performs the calculation.
1475 %************************************************************************
1477 \subsection{Argument analysis}
1479 %************************************************************************
1481 This code deals with analysing call-site arguments to see whether
1482 they are constructor applications.
1486 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1488 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1489 -- Result has no duplicate patterns,
1490 -- nor ones mentioned in done_pats
1491 -- Bool indicates that there was at least one boring pattern
1492 callsToPats env done_specs bndr_occs calls
1493 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1495 ; let good_pats :: [CallPat]
1496 good_pats = catMaybes mb_pats
1497 done_pats = [p | OS p _ _ _ <- done_specs]
1498 is_done p = any (samePat p) done_pats
1500 ; return (any isNothing mb_pats,
1501 filterOut is_done (nubBy samePat good_pats)) }
1503 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1504 -- The [Var] is the variables to quantify over in the rule
1505 -- Type variables come first, since they may scope
1506 -- over the following term variables
1507 -- The [CoreExpr] are the argument patterns for the rule
1508 callToPats env bndr_occs (con_env, args)
1509 | length args < length bndr_occs -- Check saturated
1512 = do { let in_scope = substInScope (sc_subst env)
1513 ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
1514 ; let pat_fvs = varSetElems (exprsFreeVars pats)
1515 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1516 -- Quantify over variables that are not in sccpe
1518 -- See Note [Shadowing] at the top
1520 (tvs, ids) = partition isTyCoVar qvars
1522 -- Put the type variables first; the type of a term
1523 -- variable may mention a type variable
1525 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1527 then return (Just (qvars', pats))
1528 else return Nothing }
1530 -- argToPat takes an actual argument, and returns an abstracted
1531 -- version, consisting of just the "constructor skeleton" of the
1532 -- argument, with non-constructor sub-expression replaced by new
1533 -- placeholder variables. For example:
1534 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1537 -> InScopeSet -- What's in scope at the fn defn site
1538 -> ValueEnv -- ValueEnv at the call site
1539 -> CoreArg -- A call arg (or component thereof)
1541 -> UniqSM (Bool, CoreArg)
1543 -- Returns (interesting, pat),
1544 -- where pat is the pattern derived from the argument
1545 -- interesting=True if the pattern is non-trivial (not a variable or type)
1546 -- E.g. x:xs --> (True, x:xs)
1547 -- f xs --> (False, w) where w is a fresh wildcard
1548 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1549 -- \x. x+y --> (True, \x. x+y)
1550 -- lvl7 --> (True, lvl7) if lvl7 is bound
1551 -- somewhere further out
1553 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1554 = return (False, arg)
1556 argToPat env in_scope val_env (Note _ arg) arg_occ
1557 = argToPat env in_scope val_env arg arg_occ
1558 -- Note [Notes in call patterns]
1559 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1560 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1561 -- Perhaps we should not ignore profiling notes, but I'm going to
1562 -- ride roughshod over them all for now.
1563 --- See Note [Notes in RULE matching] in Rules
1565 argToPat env in_scope val_env (Let _ arg) arg_occ
1566 = argToPat env in_scope val_env arg arg_occ
1567 -- See Note [Matching lets] in Rule.lhs
1568 -- Look through let expressions
1569 -- e.g. f (let v = rhs in (v,w))
1570 -- Here we can specialise for f (v,w)
1571 -- because the rule-matcher will look through the let.
1573 {- Disabled; see Note [Matching cases] in Rule.lhs
1574 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1575 | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
1576 = argToPat env in_scope val_env rhs arg_occ
1579 argToPat env in_scope val_env (Cast arg co) arg_occ
1580 | isIdentityCoercion co -- Substitution in the SpecConstr itself
1581 -- can lead to identity coercions
1582 = argToPat env in_scope val_env arg arg_occ
1583 | not (ignoreType env ty2)
1584 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1585 ; if not interesting then
1588 { -- Make a wild-card pattern for the coercion
1590 ; let co_name = mkSysTvName uniq (fsLit "sg")
1591 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1592 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1594 (ty1, ty2) = coercionKind co
1598 {- Disabling lambda specialisation for now
1599 It's fragile, and the spec_loop can be infinite
1600 argToPat in_scope val_env arg arg_occ
1602 = return (True, arg)
1604 is_value_lam (Lam v e) -- Spot a value lambda, even if
1605 | isId v = True -- it is inside a type lambda
1606 | otherwise = is_value_lam e
1607 is_value_lam other = False
1610 -- Check for a constructor application
1611 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1612 argToPat env in_scope val_env arg arg_occ
1613 | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
1614 , not (ignoreDataCon env dc) -- See Note [NoSpecConstr]
1615 , Just arg_occs <- mb_scrut dc
1616 = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
1617 ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
1619 mkConApp dc (ty_args ++ args')) }
1621 mb_scrut dc = case arg_occ of
1623 | Just occs <- lookupUFM bs dc
1624 -> Just (occs) -- See Note [Reboxing]
1625 _other | sc_force env -> Just (repeat UnkOcc)
1626 | otherwise -> Nothing
1628 -- Check if the argument is a variable that
1629 -- (a) is used in an interesting way in the body
1630 -- (b) we know what its value is
1631 -- In that case it counts as "interesting"
1632 argToPat env in_scope val_env (Var v) arg_occ
1633 | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1635 not (ignoreType env (varType v))
1636 = return (True, Var v)
1639 | isLocalId v = v `elemInScopeSet` in_scope
1640 && isJust (lookupVarEnv val_env v)
1641 -- Local variables have values in val_env
1642 | otherwise = isValueUnfolding (idUnfolding v)
1643 -- Imports have unfoldings
1645 -- I'm really not sure what this comment means
1646 -- And by not wild-carding we tend to get forall'd
1647 -- variables that are in soope, which in turn can
1648 -- expose the weakness in let-matching
1649 -- See Note [Matching lets] in Rules
1651 -- Check for a variable bound inside the function.
1652 -- Don't make a wild-card, because we may usefully share
1653 -- e.g. f a = let x = ... in f (x,x)
1654 -- NB: this case follows the lambda and con-app cases!!
1655 -- argToPat _in_scope _val_env (Var v) _arg_occ
1656 -- = return (False, Var v)
1657 -- SLPJ : disabling this to avoid proliferation of versions
1658 -- also works badly when thinking about seeding the loop
1659 -- from the body of the let
1660 -- f x y = letrec g z = ... in g (x,y)
1661 -- We don't want to specialise for that *particular* x,y
1663 -- The default case: make a wild-card
1664 argToPat _env _in_scope _val_env arg _arg_occ
1665 = wildCardPat (exprType arg)
1667 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1669 = do { uniq <- getUniqueUs
1670 ; let id = mkSysLocal (fsLit "sc") uniq ty
1671 ; return (False, Var id) }
1673 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1674 -> [CoreArg] -> [ArgOcc] -- Should be same length
1675 -> UniqSM (Bool, [CoreArg])
1676 argsToPats env in_scope val_env args occs
1677 = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
1678 ; let (interesting_s, args') = unzip stuff
1679 ; return (or interesting_s, args') }
1684 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1685 isValue _env (Lit lit)
1686 = Just (ConVal (LitAlt lit) [])
1689 | Just stuff <- lookupVarEnv env v
1690 = Just stuff -- You might think we could look in the idUnfolding here
1691 -- but that doesn't take account of which branch of a
1692 -- case we are in, which is the whole point
1694 | not (isLocalId v) && isCheapUnfolding unf
1695 = isValue env (unfoldingTemplate unf)
1698 -- However we do want to consult the unfolding
1699 -- as well, for let-bound constructors!
1701 isValue env (Lam b e)
1702 | isTyCoVar b = case isValue env e of
1703 Just _ -> Just LambdaVal
1705 | otherwise = Just LambdaVal
1707 isValue _env expr -- Maybe it's a constructor application
1708 | (Var fun, args) <- collectArgs expr
1709 = case isDataConWorkId_maybe fun of
1711 Just con | args `lengthAtLeast` dataConRepArity con
1712 -- Check saturated; might be > because the
1713 -- arity excludes type args
1714 -> Just (ConVal (DataAlt con) args)
1716 _other | valArgCount args < idArity fun
1717 -- Under-applied function
1718 -> Just LambdaVal -- Partial application
1722 isValue _env _expr = Nothing
1724 samePat :: CallPat -> CallPat -> Bool
1725 samePat (vs1, as1) (vs2, as2)
1728 same (Var v1) (Var v2)
1729 | v1 `elem` vs1 = v2 `elem` vs2
1730 | v2 `elem` vs2 = False
1731 | otherwise = v1 == v2
1733 same (Lit l1) (Lit l2) = l1==l2
1734 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1736 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1737 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1738 same (Cast e1 _) e2 = same e1 e2
1739 same e1 (Note _ e2) = same e1 e2
1740 same e1 (Cast e2 _) = same e1 e2
1742 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1743 False -- Let, lambda, case should not occur
1744 bad (Case {}) = True
1750 Note [Ignore type differences]
1751 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1752 We do not want to generate specialisations where the call patterns
1753 differ only in their type arguments! Not only is it utterly useless,
1754 but it also means that (with polymorphic recursion) we can generate
1755 an infinite number of specialisations. Example is Data.Sequence.adjustTree,