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 Literal ( literalType )
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 Note [Do not specialise diverging functions]
391 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
392 Specialising a function that just diverges is a waste of code.
393 Furthermore, it broke GHC (simpl014) thus:
395 f = \x. case x of (a,b) -> f x
396 If we specialise f we get
397 f = \x. case x of (a,b) -> fspec a b
398 But fspec doesn't have decent strictnes info. As it happened,
399 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
400 and hence f. But now f's strictness is less than its arity, which
403 Note [SpecConstrAnnotation]
404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
405 SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
406 be available in stage 2 (well, until the bootstrap compiler can be
407 guaranteed to have it)
409 So we define it to be () in stage1 (ie when GHCI is undefined), and
410 '#ifdef' out the code that uses it.
412 See also Note [Forcing specialisation]
414 Note [Forcing specialisation]
415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
416 With stream fusion and in other similar cases, we want to fully specialise
417 some (but not necessarily all!) loops regardless of their size and the
418 number of specialisations. We allow a library to specify this by annotating
419 a type with ForceSpecConstr and then adding a parameter of that type to the
420 loop. Here is a (simplified) example from the vector library:
422 data SPEC = SPEC | SPEC2
423 {-# ANN type SPEC ForceSpecConstr #-}
425 foldl :: (a -> b -> a) -> a -> Stream b -> a
427 foldl f z (Stream step s _) = foldl_loop SPEC z s
429 foldl_loop !sPEC z s = case step s of
430 Yield x s' -> foldl_loop sPEC (f z x) s'
431 Skip -> foldl_loop sPEC z s'
434 SpecConstr will spot the SPEC parameter and always fully specialise
435 foldl_loop. Note that
437 * We have to prevent the SPEC argument from being removed by
438 w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
441 * And lastly, the SPEC argument is ultimately eliminated by
442 SpecConstr itself so there is no runtime overhead.
444 This is all quite ugly; we ought to come up with a better design.
446 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
447 sc_force to True when calling specLoop. This flag does three things:
448 * Ignore specConstrThreshold, to specialise functions of arbitrary size
450 * Ignore specConstrCount, to make arbitrary numbers of specialisations
452 * Specialise even for arguments that are not scrutinised in the loop
453 (see argToPat; Trac #4488)
455 This flag is inherited for nested non-recursive bindings (which are likely to
456 be join points and hence should be fully specialised) but reset for nested
459 What alternatives did I consider? Annotating the loop itself doesn't
460 work because (a) it is local and (b) it will be w/w'ed and I having
461 w/w propagating annotation somehow doesn't seem like a good idea. The
462 types of the loop arguments really seem to be the most persistent
465 Annotating the types that make up the loop state doesn't work,
466 either, because (a) it would prevent us from using types like Either
467 or tuples here, (b) we don't want to restrict the set of types that
468 can be used in Stream states and (c) some types are fixed by the user
469 (e.g., the accumulator here) but we still want to specialise as much
472 ForceSpecConstr is done by way of an annotation:
473 data SPEC = SPEC | SPEC2
474 {-# ANN type SPEC ForceSpecConstr #-}
475 But SPEC is the *only* type so annotated, so it'd be better to
476 use a particular library type.
478 Alternatives to ForceSpecConstr
479 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
480 Instead of giving the loop an extra argument of type SPEC, we
481 also considered *wrapping* arguments in SPEC, thus
482 data SPEC a = SPEC a | SPEC2
484 loop = \arg -> case arg of
486 case state of (x,y) -> ... loop (SPEC (x',y')) ...
488 The idea is that a SPEC argument says "specialise this argument
489 regardless of whether the function case-analyses it. But this
491 * SPEC must still be a sum type, else the strictness analyser
493 * But that means that 'loop' won't be strict in its real payload
494 This loss of strictness in turn screws up specialisation, because
495 we may end up with calls like
496 loop (SPEC (case z of (p,q) -> (q,p)))
497 Without the SPEC, if 'loop' was strict, the case would move out
498 and we'd see loop applied to a pair. But if 'loop' isn' strict
499 this doesn't look like a specialisable call.
503 The ignoreAltCon stuff allows you to say
504 {-# ANN type T NoSpecConstr #-}
505 to mean "don't specialise on arguments of this type. It was added
506 before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised
507 regardless of size; and then we needed a way to turn that *off*. Now
508 that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
509 (Used only for PArray.)
511 -----------------------------------------------------
512 Stuff not yet handled
513 -----------------------------------------------------
515 Here are notes arising from Roman's work that I don't want to lose.
521 foo :: Int -> T Int -> Int
523 foo x t | even x = case t of { T n -> foo (x-n) t }
524 | otherwise = foo (x-1) t
526 SpecConstr does no specialisation, because the second recursive call
527 looks like a boxed use of the argument. A pity.
529 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
531 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
532 case ww_sFo of ds_Xw6 [Just L] {
534 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
535 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
537 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
538 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
539 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
545 data a :*: b = !a :*: !b
548 foo :: (Int :*: T Int) -> Int
550 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
551 | otherwise = foo ((x-1) :*: t)
553 Very similar to the previous one, except that the parameters are now in
554 a strict tuple. Before SpecConstr, we have
556 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
558 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
560 case ww_sFU of ds_Xws [Just L] {
562 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
564 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
565 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
568 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
569 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
570 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
574 We get two specialisations:
575 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
576 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
577 = Foo.$s$wfoo1 a_sFB sc_sGC ;
578 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
579 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
580 = Foo.$s$wfoo y_aFp sc_sGC ;
582 But perhaps the first one isn't good. After all, we know that tpl_B2 is
583 a T (I# x) really, because T is strict and Int has one constructor. (We can't
584 unbox the strict fields, becuase T is polymorphic!)
586 %************************************************************************
588 \subsection{Top level wrapper stuff}
590 %************************************************************************
593 specConstrProgram :: ModGuts -> CoreM ModGuts
594 specConstrProgram guts
596 dflags <- getDynFlags
597 us <- getUniqueSupplyM
598 annos <- getFirstAnnotations deserializeWithData guts
599 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
600 return (guts { mg_binds = binds' })
603 go env (bind:binds) = do (env', bind') <- scTopBind env bind
604 binds' <- go env' binds
605 return (bind' : binds')
609 %************************************************************************
611 \subsection{Environment: goes downwards}
613 %************************************************************************
616 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
617 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
618 -- See Note [Avoiding exponential blowup]
619 sc_force :: Bool, -- Force specialisation?
620 -- See Note [Forcing specialisation]
622 sc_subst :: Subst, -- Current substitution
623 -- Maps InIds to OutExprs
625 sc_how_bound :: HowBoundEnv,
626 -- Binds interesting non-top-level variables
627 -- Domain is OutVars (*after* applying the substitution)
630 -- Domain is OutIds (*after* applying the substitution)
631 -- Used even for top-level bindings (but not imported ones)
633 sc_annotations :: UniqFM SpecConstrAnnotation
636 ---------------------
637 -- As we go, we apply a substitution (sc_subst) to the current term
638 type InExpr = CoreExpr -- _Before_ applying the subst
641 type OutExpr = CoreExpr -- _After_ applying the subst
645 ---------------------
646 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
648 ---------------------
649 type ValueEnv = IdEnv Value -- Domain is OutIds
650 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
651 -- The AltCon is never DEFAULT
652 | LambdaVal -- Inlinable lambdas or PAPs
654 instance Outputable Value where
655 ppr (ConVal con args) = ppr con <+> interpp'SP args
656 ppr LambdaVal = ptext (sLit "<Lambda>")
658 ---------------------
659 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
660 initScEnv dflags anns
661 = SCE { sc_size = specConstrThreshold dflags,
662 sc_count = specConstrCount dflags,
664 sc_subst = emptySubst,
665 sc_how_bound = emptyVarEnv,
666 sc_vals = emptyVarEnv,
667 sc_annotations = anns }
669 data HowBound = RecFun -- These are the recursive functions for which
670 -- we seek interesting call patterns
672 | RecArg -- These are those functions' arguments, or their sub-components;
673 -- we gather occurrence information for these
675 instance Outputable HowBound where
676 ppr RecFun = text "RecFun"
677 ppr RecArg = text "RecArg"
679 scForce :: ScEnv -> Bool -> ScEnv
680 scForce env b = env { sc_force = b }
682 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
683 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
685 scSubstId :: ScEnv -> Id -> CoreExpr
686 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
688 scSubstTy :: ScEnv -> Type -> Type
689 scSubstTy env ty = substTy (sc_subst env) ty
691 zapScSubst :: ScEnv -> ScEnv
692 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
694 extendScInScope :: ScEnv -> [Var] -> ScEnv
695 -- Bring the quantified variables into scope
696 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
698 -- Extend the substitution
699 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
700 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
702 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
703 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
705 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
706 extendHowBound env bndrs how_bound
707 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
708 [(bndr,how_bound) | bndr <- bndrs] }
710 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
711 extendBndrsWith how_bound env bndrs
712 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
714 (subst', bndrs') = substBndrs (sc_subst env) bndrs
715 hb_env' = sc_how_bound env `extendVarEnvList`
716 [(bndr,how_bound) | bndr <- bndrs']
718 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
719 extendBndrWith how_bound env bndr
720 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
722 (subst', bndr') = substBndr (sc_subst env) bndr
723 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
725 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
726 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
728 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
730 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
731 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
733 (subst', bndr') = substBndr (sc_subst env) bndr
735 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
736 extendValEnv env _ Nothing = env
737 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
739 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
743 -- we want to bind b, to (C x y)
744 -- NB1: Extends only the sc_vals part of the envt
745 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
746 -- they are potentially made alive by the [b -> C x y] binding
747 extendCaseBndrs env case_bndr con alt_bndrs
748 | isDeadBinder case_bndr
751 = (env1, map zap alt_bndrs)
752 -- NB: We used to bind v too, if scrut = (Var v); but
753 -- the simplifer has already done this so it seems
754 -- redundant to do so here
756 -- Var v -> extendValEnv env1 v cval
759 zap v | isTyCoVar v = v -- See NB2 above
760 | otherwise = zapIdOccInfo v
761 env1 = extendValEnv env case_bndr cval
764 LitAlt {} -> Just (ConVal con [])
765 DataAlt {} -> Just (ConVal con vanilla_args)
767 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
768 varsToCoreExprs alt_bndrs
771 decreaseSpecCount :: ScEnv -> Int -> ScEnv
772 -- See Note [Avoiding exponential blowup]
773 decreaseSpecCount env n_specs
774 = env { sc_count = case sc_count env of
776 Just n -> Just (n `div` (n_specs + 1)) }
777 -- The "+1" takes account of the original function;
778 -- See Note [Avoiding exponential blowup]
780 ---------------------------------------------------
781 -- See Note [SpecConstrAnnotation]
782 ignoreType :: ScEnv -> Type -> Bool
783 ignoreAltCon :: ScEnv -> AltCon -> Bool
784 forceSpecBndr :: ScEnv -> Var -> Bool
786 ignoreType _ _ = False
787 ignoreAltCon _ _ = False
788 forceSpecBndr _ _ = False
792 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
793 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
794 ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal
797 = case splitTyConApp_maybe ty of
798 Just (tycon, _) -> ignoreTyCon env tycon
801 ignoreTyCon :: ScEnv -> TyCon -> Bool
802 ignoreTyCon env tycon
803 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
805 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
807 forceSpecFunTy :: ScEnv -> Type -> Bool
808 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
810 forceSpecArgTy :: ScEnv -> Type -> Bool
811 forceSpecArgTy env ty
812 | Just ty' <- coreView ty = forceSpecArgTy env ty'
814 forceSpecArgTy env ty
815 | Just (tycon, tys) <- splitTyConApp_maybe ty
817 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
818 || any (forceSpecArgTy env) tys
820 forceSpecArgTy _ _ = False
824 Note [Avoiding exponential blowup]
825 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
826 The sc_count field of the ScEnv says how many times we are prepared to
827 duplicate a single function. But we must take care with recursive
828 specialiations. Consider
830 let $j1 = let $j2 = let $j3 = ...
838 If we specialise $j1 then in each specialisation (as well as the original)
839 we can specialise $j2, and similarly $j3. Even if we make just *one*
840 specialisation of each, becuase we also have the original we'll get 2^n
841 copies of $j3, which is not good.
843 So when recursively specialising we divide the sc_count by the number of
844 copies we are making at this level, including the original.
847 %************************************************************************
849 \subsection{Usage information: flows upwards}
851 %************************************************************************
856 scu_calls :: CallEnv, -- Calls
857 -- The functions are a subset of the
858 -- RecFuns in the ScEnv
860 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
861 } -- The domain is OutIds
863 type CallEnv = IdEnv [Call]
864 type Call = (ValueEnv, [CoreArg])
865 -- The arguments of the call, together with the
866 -- env giving the constructor bindings at the call site
869 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
871 combineCalls :: CallEnv -> CallEnv -> CallEnv
872 combineCalls = plusVarEnv_C (++)
874 combineUsage :: ScUsage -> ScUsage -> ScUsage
875 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
876 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
878 combineUsages :: [ScUsage] -> ScUsage
879 combineUsages [] = nullUsage
880 combineUsages us = foldr1 combineUsage us
882 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
883 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
884 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
885 lookupVarEnv sc_occs bndr `orElse` NoOcc)
887 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
888 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
889 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
890 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
892 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
893 | UnkOcc -- Used in some unknown way
895 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
897 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
901 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
902 is *only* taken apart or applied.
904 Functions, literal: ScrutOcc emptyUFM
905 Data constructors: ScrutOcc subs,
907 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
908 The domain of the UniqFM is the Unique of the data constructor
910 The [ArgOcc] is the occurrences of the *pattern-bound* components
911 of the data structure. E.g.
912 data T a = forall b. MkT a b (b->a)
913 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
917 instance Outputable ArgOcc where
918 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
919 ppr UnkOcc = ptext (sLit "unk-occ")
920 ppr BothOcc = ptext (sLit "both-occ")
921 ppr NoOcc = ptext (sLit "no-occ")
923 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
924 -- that if the thing is scrutinised anywhere then we get to see that
925 -- in the overall result, even if it's also used in a boxed way
926 -- This might be too agressive; see Note [Reboxing] Alternative 3
927 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
928 combineOcc NoOcc occ = occ
929 combineOcc occ NoOcc = occ
930 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
931 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
932 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
933 combineOcc UnkOcc UnkOcc = UnkOcc
934 combineOcc _ _ = BothOcc
936 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
937 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
939 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
940 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
941 -- is a variable, and an interesting variable
942 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
943 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
944 setScrutOcc env usg (Var v) occ
945 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
947 setScrutOcc _env usg _other _occ -- Catch-all
950 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
951 -- Find usage of components of data con; returns [UnkOcc...] if unknown
952 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
954 conArgOccs (ScrutOcc fm) (DataAlt dc)
955 | Just pat_arg_occs <- lookupUFM fm dc
956 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
958 conArgOccs _other _con = repeat UnkOcc
961 %************************************************************************
963 \subsection{The main recursive function}
965 %************************************************************************
967 The main recursive function gathers up usage information, and
968 creates specialised versions of functions.
971 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
972 -- The unique supply is needed when we invent
973 -- a new name for the specialised function and its args
975 scExpr env e = scExpr' env e
978 scExpr' env (Var v) = case scSubstId env v of
979 Var v' -> return (varUsage env v' UnkOcc, Var v')
980 e' -> scExpr (zapScSubst env) e'
982 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
983 scExpr' _ e@(Lit {}) = return (nullUsage, e)
984 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
985 return (usg, Note n e')
986 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
987 return (usg, Cast e' (scSubstTy env co))
988 scExpr' env e@(App _ _) = scApp env (collectArgs e)
989 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
990 (usg, e') <- scExpr env' e
991 return (usg, Lam b' e')
993 scExpr' env (Case scrut b ty alts)
994 = do { (scrut_usg, scrut') <- scExpr env scrut
995 ; case isValue (sc_vals env) scrut' of
996 Just (ConVal con args) -> sc_con_app con args scrut'
997 _other -> sc_vanilla scrut_usg scrut'
1000 sc_con_app con args scrut' -- Known constructor; simplify
1001 = do { let (_, bs, rhs) = findAlt con alts
1002 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
1003 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
1004 ; scExpr alt_env' rhs }
1006 sc_vanilla scrut_usg scrut' -- Normal case
1007 = do { let (alt_env,b') = extendBndrWith RecArg env b
1008 -- Record RecArg for the components
1010 ; (alt_usgs, alt_occs, alts')
1011 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
1013 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
1014 scrut_occ = foldr combineOcc b_occ alt_occs
1015 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
1016 -- The combined usage of the scrutinee is given
1017 -- by scrut_occ, which is passed to scScrut, which
1018 -- in turn treats a bare-variable scrutinee specially
1020 ; return (alt_usg `combineUsage` scrut_usg',
1021 Case scrut' b' (scSubstTy env ty) alts') }
1023 sc_alt env _scrut' b' (con,bs,rhs)
1024 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
1025 (env2, bs2) = extendCaseBndrs env1 b' con bs1
1026 ; (usg,rhs') <- scExpr env2 rhs
1027 ; let (usg', arg_occs) = lookupOccs usg bs2
1028 scrut_occ = case con of
1029 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
1030 _ -> ScrutOcc emptyUFM
1031 ; return (usg', scrut_occ, (con, bs2, rhs')) }
1033 scExpr' env (Let (NonRec bndr rhs) body)
1034 | isTyCoVar bndr -- Type-lets may be created by doBeta
1035 = scExpr' (extendScSubst env bndr rhs) body
1038 = do { let (body_env, bndr') = extendBndr env bndr
1039 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
1041 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
1042 -- Note [Local let bindings]
1043 RI _ rhs' _ _ _ = rhs_info
1044 body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
1046 ; (body_usg, body') <- scExpr body_env3 body
1048 -- NB: For non-recursive bindings we inherit sc_force flag from
1049 -- the parent function (see Note [Forcing specialisation])
1050 ; (spec_usg, specs) <- specialise env
1051 (scu_calls body_usg)
1053 (SI [] 0 (Just rhs_usg))
1055 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1056 `combineUsage` spec_usg,
1057 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1061 -- A *local* recursive group: see Note [Local recursive groups]
1062 scExpr' env (Let (Rec prs) body)
1063 = do { let (bndrs,rhss) = unzip prs
1064 (rhs_env1,bndrs') = extendRecBndrs env bndrs
1065 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1066 force_spec = any (forceSpecBndr env) bndrs'
1067 -- Note [Forcing specialisation]
1069 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1070 ; (body_usg, body') <- scExpr rhs_env2 body
1072 -- NB: start specLoop from body_usg
1073 ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
1074 (scu_calls body_usg) rhs_infos nullUsage
1075 [SI [] 0 (Just usg) | usg <- rhs_usgs]
1076 -- Do not unconditionally use rhs_usgs.
1077 -- Instead use them only if we find an unspecialised call
1078 -- See Note [Local recursive groups]
1080 ; let all_usg = spec_usg `combineUsage` body_usg
1081 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1083 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1087 Note [Local let bindings]
1088 ~~~~~~~~~~~~~~~~~~~~~~~~~
1089 It is not uncommon to find this
1091 let $j = \x. <blah> in ...$j True...$j True...
1093 Here $j is an arbitrary let-bound function, but it often comes up for
1094 join points. We might like to specialise $j for its call patterns.
1095 Notice the difference from a letrec, where we look for call patterns
1096 in the *RHS* of the function. Here we look for call patterns in the
1099 At one point I predicated this on the RHS mentioning the outer
1100 recursive function, but that's not essential and might even be
1101 harmful. I'm not sure.
1105 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1107 scApp env (Var fn, args) -- Function is a variable
1108 = ASSERT( not (null args) )
1109 do { args_w_usgs <- mapM (scExpr env) args
1110 ; let (arg_usgs, args') = unzip args_w_usgs
1111 arg_usg = combineUsages arg_usgs
1112 ; case scSubstId env fn of
1113 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1114 -- Do beta-reduction and try again
1116 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1118 fn_usg = case lookupHowBound env fn' of
1119 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
1120 scu_occs = emptyVarEnv }
1121 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1122 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
1123 Nothing -> nullUsage
1126 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1127 -- NB: doing this ignores any usage info from the substituted
1128 -- function, but I don't think that matters. If it does
1131 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1132 -- ToDo: adjust for System IF
1133 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1134 doBeta fn args = mkApps fn args
1136 -- The function is almost always a variable, but not always.
1137 -- In particular, if this pass follows float-in,
1138 -- which it may, we can get
1139 -- (let f = ...f... in f) arg1 arg2
1140 scApp env (other_fn, args)
1141 = do { (fn_usg, fn') <- scExpr env other_fn
1142 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1143 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1145 ----------------------
1146 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1147 scTopBind env (Rec prs)
1148 | Just threshold <- sc_size env
1150 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1151 -- No specialisation
1152 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1153 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1154 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1155 | otherwise -- Do specialisation
1156 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1157 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1159 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1160 ; let rhs_usg = combineUsages rhs_usgs
1162 ; (_, specs) <- specLoop (scForce rhs_env2 force_spec)
1163 (scu_calls rhs_usg) rhs_infos nullUsage
1164 [SI [] 0 Nothing | _ <- bndrs]
1166 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1167 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1169 (bndrs,rhss) = unzip prs
1170 force_spec = any (forceSpecBndr env) bndrs
1171 -- Note [Forcing specialisation]
1173 scTopBind env (NonRec bndr rhs)
1174 = do { (_, rhs') <- scExpr env rhs
1175 ; let (env1, bndr') = extendBndr env bndr
1176 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1177 ; return (env2, NonRec bndr' rhs') }
1179 ----------------------
1180 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1181 scRecRhs env (bndr,rhs)
1182 = do { let (arg_bndrs,body) = collectBinders rhs
1183 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1184 ; (body_usg, body') <- scExpr body_env body
1185 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1186 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1187 arg_bndrs body arg_occs) }
1188 -- The arg_occs says how the visible,
1189 -- lambda-bound binders of the RHS are used
1190 -- (including the TyVar binders)
1191 -- Two pats are the same if they match both ways
1193 ----------------------
1194 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1195 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1196 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1197 [(fn `addIdSpecialisations` rules, new_rhs)]
1199 rules = [r | OS _ r _ _ <- specs]
1201 ----------------------
1202 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1204 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1205 , scu_occs = unitVarEnv v use }
1206 | otherwise = nullUsage
1210 %************************************************************************
1212 The specialiser itself
1214 %************************************************************************
1217 data RhsInfo = RI OutId -- The binder
1218 OutExpr -- The new RHS
1219 [InVar] InExpr -- The *original* RHS (\xs.body)
1220 -- Note [Specialise original body]
1221 [ArgOcc] -- Info on how the xs occur in body
1223 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1225 Int -- Length of specs; used for numbering them
1227 (Maybe ScUsage) -- Nothing => we have generated specialisations
1228 -- from calls in the *original* RHS
1229 -- Just cs => we haven't, and this is the usage
1230 -- of the original RHS
1231 -- See Note [Local recursive groups]
1233 -- One specialisation: Rule plus definition
1234 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1235 CoreRule -- Rule connecting original id with the specialisation
1236 OutId OutExpr -- Spec id + its rhs
1242 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1243 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1244 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1245 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1246 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1247 new_usg = combineUsages new_usg_s
1248 new_calls = scu_calls new_usg
1249 all_usg = usg_so_far `combineUsage` new_usg
1250 ; if isEmptyVarEnv new_calls then
1251 return (all_usg, all_specs)
1253 specLoop env new_calls rhs_infos all_usg all_specs }
1257 -> CallEnv -- Info on calls
1259 -> SpecInfo -- Original RHS plus patterns dealt with
1260 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1262 -- Note: the rhs here is the optimised version of the original rhs
1263 -- So when we make a specialised copy of the RHS, we're starting
1264 -- from an RHS whose nested functions have been optimised already.
1266 specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
1267 spec_info@(SI specs spec_count mb_unspec)
1268 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1269 , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1270 , notNull arg_bndrs -- Only specialise functions
1271 , Just all_calls <- lookupVarEnv bind_calls fn
1272 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1273 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1274 -- , text "arg_occs" <+> ppr arg_occs
1275 -- , text "calls" <+> ppr all_calls
1276 -- , text "good pats" <+> ppr pats]) $
1279 -- Bale out if too many specialisations
1280 ; let n_pats = length pats
1281 spec_count' = n_pats + spec_count
1282 ; case sc_count env of
1283 Just max | not (sc_force env) && spec_count' > max
1284 -> pprTrace "SpecConstr" msg $
1285 return (nullUsage, spec_info)
1287 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1288 , nest 2 (ptext (sLit "has") <+>
1289 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1290 ptext (sLit "but the limit is") <+> int max) ]
1291 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1293 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1294 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1296 _normal_case -> do {
1298 let spec_env = decreaseSpecCount env n_pats
1299 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1300 (pats `zip` [spec_count..])
1301 -- See Note [Specialise original body]
1303 ; let spec_usg = combineUsages spec_usgs
1304 (new_usg, mb_unspec')
1306 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1307 _ -> (spec_usg, mb_unspec)
1309 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1311 = return (nullUsage, spec_info) -- The boring case
1314 ---------------------
1316 -> OutId -- Function
1317 -> [InVar] -- Lambda-binders of RHS; should match patterns
1318 -> InExpr -- Body of the original function
1320 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1322 -- spec_one creates a specialised copy of the function, together
1323 -- with a rule for using it. I'm very proud of how short this
1324 -- function is, considering what it does :-).
1330 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1331 [c::*, v::(b,c) are presumably bound by the (...) part]
1333 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1334 (...entire body of f...) [b -> (b,c),
1335 y -> ((:) (a,(b,c)) (x,v) hw)]
1337 RULE: forall b::* c::*, -- Note, *not* forall a, x
1341 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1344 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1345 = do { spec_uniq <- getUniqueUs
1346 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1347 (arg_bndrs `zip` pats)
1349 fn_loc = nameSrcSpan fn_name
1350 spec_occ = mkSpecOcc (nameOccName fn_name)
1351 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1352 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1353 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1356 -- Specialise the body
1357 ; (spec_usg, spec_body) <- scExpr spec_env body
1359 -- ; pprTrace "done spec_one}" (ppr fn) $
1362 -- And build the results
1363 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1364 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1365 `setIdArity` count isId spec_lam_args
1366 spec_str = calcSpecStrictness fn spec_lam_args pats
1367 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1368 -- Usual w/w hack to avoid generating
1369 -- a spec_rhs of unlifted type and no args
1371 spec_rhs = mkLams spec_lam_args spec_body
1372 body_ty = exprType spec_body
1373 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1374 inline_act = idInlineActivation fn
1375 rule = mkRule True {- Auto -} True {- Local -}
1376 rule_name inline_act fn_name qvars pats rule_rhs
1377 -- See Note [Transfer activation]
1378 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1380 calcSpecStrictness :: Id -- The original function
1381 -> [Var] -> [CoreExpr] -- Call pattern
1382 -> StrictSig -- Strictness of specialised thing
1383 -- See Note [Transfer strictness]
1384 calcSpecStrictness fn qvars pats
1385 = StrictSig (mkTopDmdType spec_dmds TopRes)
1387 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1388 StrictSig (DmdType _ dmds _) = idStrictness fn
1390 dmd_env = go emptyVarEnv dmds pats
1392 go env ds (Type {} : pats) = go env ds pats
1393 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1396 go_one env d (Var v) = extendVarEnv_C both env v d
1397 go_one env (Box d) e = go_one env d e
1398 go_one env (Eval (Prod ds)) e
1399 | (Var _, args) <- collectArgs e = go env ds args
1400 go_one env _ _ = env
1404 Note [Specialise original body]
1405 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1406 The RhsInfo for a binding keeps the *original* body of the binding. We
1407 must specialise that, *not* the result of applying specExpr to the RHS
1408 (which is also kept in RhsInfo). Otherwise we end up specialising a
1409 specialised RHS, and that can lead directly to exponential behaviour.
1411 Note [Transfer activation]
1412 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1413 This note is for SpecConstr, but exactly the same thing
1414 happens in the overloading specialiser; see
1415 Note [Auto-specialisation and RULES] in Specialise.
1417 In which phase should the specialise-constructor rules be active?
1418 Originally I made them always-active, but Manuel found that this
1419 defeated some clever user-written rules. Then I made them active only
1420 in Phase 0; after all, currently, the specConstr transformation is
1421 only run after the simplifier has reached Phase 0, but that meant
1422 that specialisations didn't fire inside wrappers; see test
1423 simplCore/should_compile/spec-inline.
1425 So now I just use the inline-activation of the parent Id, as the
1426 activation for the specialiation RULE, just like the main specialiser;
1428 This in turn means there is no point in specialising NOINLINE things,
1429 so we test for that.
1431 Note [Transfer strictness]
1432 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1433 We must transfer strictness information from the original function to
1434 the specialised one. Suppose, for example
1437 and a RULE f (a:as) b = f_spec a as b
1439 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1440 when calling f_spec instead of call-by-value. And that can result in
1441 unbounded worsening in space (cf the classic foldl vs foldl')
1443 See Trac #3437 for a good example.
1445 The function calcSpecStrictness performs the calculation.
1448 %************************************************************************
1450 \subsection{Argument analysis}
1452 %************************************************************************
1454 This code deals with analysing call-site arguments to see whether
1455 they are constructor applications.
1459 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1462 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1463 -- Result has no duplicate patterns,
1464 -- nor ones mentioned in done_pats
1465 -- Bool indicates that there was at least one boring pattern
1466 callsToPats env done_specs bndr_occs calls
1467 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1469 ; let good_pats :: [([Var], [CoreArg])]
1470 good_pats = catMaybes mb_pats
1471 done_pats = [p | OS p _ _ _ <- done_specs]
1472 is_done p = any (samePat p) done_pats
1474 ; return (any isNothing mb_pats,
1475 filterOut is_done (nubBy samePat good_pats)) }
1477 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1478 -- The [Var] is the variables to quantify over in the rule
1479 -- Type variables come first, since they may scope
1480 -- over the following term variables
1481 -- The [CoreExpr] are the argument patterns for the rule
1482 callToPats env bndr_occs (con_env, args)
1483 | length args < length bndr_occs -- Check saturated
1486 = do { let in_scope = substInScope (sc_subst env)
1487 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1488 ; let (interesting_s, pats) = unzip prs
1489 pat_fvs = varSetElems (exprsFreeVars pats)
1490 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1491 -- Quantify over variables that are not in sccpe
1493 -- See Note [Shadowing] at the top
1495 (tvs, ids) = partition isTyCoVar qvars
1497 -- Put the type variables first; the type of a term
1498 -- variable may mention a type variable
1500 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1502 then return (Just (qvars', pats))
1503 else return Nothing }
1505 -- argToPat takes an actual argument, and returns an abstracted
1506 -- version, consisting of just the "constructor skeleton" of the
1507 -- argument, with non-constructor sub-expression replaced by new
1508 -- placeholder variables. For example:
1509 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1512 -> InScopeSet -- What's in scope at the fn defn site
1513 -> ValueEnv -- ValueEnv at the call site
1514 -> CoreArg -- A call arg (or component thereof)
1516 -> UniqSM (Bool, CoreArg)
1517 -- Returns (interesting, pat),
1518 -- where pat is the pattern derived from the argument
1519 -- intersting=True if the pattern is non-trivial (not a variable or type)
1520 -- E.g. x:xs --> (True, x:xs)
1521 -- f xs --> (False, w) where w is a fresh wildcard
1522 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1523 -- \x. x+y --> (True, \x. x+y)
1524 -- lvl7 --> (True, lvl7) if lvl7 is bound
1525 -- somewhere further out
1527 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1528 = return (False, arg)
1530 argToPat env in_scope val_env (Note _ arg) arg_occ
1531 = argToPat env in_scope val_env arg arg_occ
1532 -- Note [Notes in call patterns]
1533 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1534 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1535 -- Perhaps we should not ignore profiling notes, but I'm going to
1536 -- ride roughshod over them all for now.
1537 --- See Note [Notes in RULE matching] in Rules
1539 argToPat env in_scope val_env (Let _ arg) arg_occ
1540 = argToPat env in_scope val_env arg arg_occ
1541 -- See Note [Matching lets] in Rule.lhs
1542 -- Look through let expressions
1543 -- e.g. f (let v = rhs in (v,w))
1544 -- Here we can specialise for f (v,w)
1545 -- because the rule-matcher will look through the let.
1547 {- Disabled; see Note [Matching cases] in Rule.lhs
1548 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1549 | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
1550 = argToPat env in_scope val_env rhs arg_occ
1553 argToPat env in_scope val_env (Cast arg co) arg_occ
1554 | isIdentityCoercion co -- Substitution in the SpecConstr itself
1555 -- can lead to identity coercions
1556 = argToPat env in_scope val_env arg arg_occ
1557 | not (ignoreType env ty2)
1558 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1559 ; if not interesting then
1562 { -- Make a wild-card pattern for the coercion
1564 ; let co_name = mkSysTvName uniq (fsLit "sg")
1565 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1566 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1568 (ty1, ty2) = coercionKind co
1572 {- Disabling lambda specialisation for now
1573 It's fragile, and the spec_loop can be infinite
1574 argToPat in_scope val_env arg arg_occ
1576 = return (True, arg)
1578 is_value_lam (Lam v e) -- Spot a value lambda, even if
1579 | isId v = True -- it is inside a type lambda
1580 | otherwise = is_value_lam e
1581 is_value_lam other = False
1584 -- Check for a constructor application
1585 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1586 argToPat env in_scope val_env arg arg_occ
1587 | Just (ConVal dc args) <- isValue val_env arg
1588 , not (ignoreAltCon env dc) -- See Note [NoSpecConstr]
1589 , sc_force env || scrutinised
1590 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1591 ; return (True, mk_con_app dc (map snd args')) }
1595 ScrutOcc _ -> True -- Used only by case scrutinee
1596 BothOcc -> case arg of -- Used elsewhere
1597 App {} -> True -- see Note [Reboxing]
1599 _other -> False -- No point; the arg is not decomposed
1602 -- Check if the argument is a variable that
1603 -- is in scope at the function definition site
1604 -- It's worth specialising on this if
1605 -- (a) it's used in an interesting way in the body
1606 -- (b) we know what its value is
1607 argToPat env in_scope val_env (Var v) arg_occ
1608 | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1610 not (ignoreType env (varType v))
1611 = return (True, Var v)
1614 | isLocalId v = v `elemInScopeSet` in_scope
1615 && isJust (lookupVarEnv val_env v)
1616 -- Local variables have values in val_env
1617 | otherwise = isValueUnfolding (idUnfolding v)
1618 -- Imports have unfoldings
1620 -- I'm really not sure what this comment means
1621 -- And by not wild-carding we tend to get forall'd
1622 -- variables that are in soope, which in turn can
1623 -- expose the weakness in let-matching
1624 -- See Note [Matching lets] in Rules
1626 -- Check for a variable bound inside the function.
1627 -- Don't make a wild-card, because we may usefully share
1628 -- e.g. f a = let x = ... in f (x,x)
1629 -- NB: this case follows the lambda and con-app cases!!
1630 -- argToPat _in_scope _val_env (Var v) _arg_occ
1631 -- = return (False, Var v)
1632 -- SLPJ : disabling this to avoid proliferation of versions
1633 -- also works badly when thinking about seeding the loop
1634 -- from the body of the let
1635 -- f x y = letrec g z = ... in g (x,y)
1636 -- We don't want to specialise for that *particular* x,y
1638 -- The default case: make a wild-card
1639 argToPat _env _in_scope _val_env arg _arg_occ
1640 = wildCardPat (exprType arg)
1642 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1643 wildCardPat ty = do { uniq <- getUniqueUs
1644 ; let id = mkSysLocal (fsLit "sc") uniq ty
1645 ; return (False, Var id) }
1647 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1648 -> [(CoreArg, ArgOcc)]
1649 -> UniqSM [(Bool, CoreArg)]
1650 argsToPats env in_scope val_env args
1653 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1658 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1659 isValue _env (Lit lit)
1660 = Just (ConVal (LitAlt lit) [])
1663 | Just stuff <- lookupVarEnv env v
1664 = Just stuff -- You might think we could look in the idUnfolding here
1665 -- but that doesn't take account of which branch of a
1666 -- case we are in, which is the whole point
1668 | not (isLocalId v) && isCheapUnfolding unf
1669 = isValue env (unfoldingTemplate unf)
1672 -- However we do want to consult the unfolding
1673 -- as well, for let-bound constructors!
1675 isValue env (Lam b e)
1676 | isTyCoVar b = case isValue env e of
1677 Just _ -> Just LambdaVal
1679 | otherwise = Just LambdaVal
1681 isValue _env expr -- Maybe it's a constructor application
1682 | (Var fun, args) <- collectArgs expr
1683 = case isDataConWorkId_maybe fun of
1685 Just con | args `lengthAtLeast` dataConRepArity con
1686 -- Check saturated; might be > because the
1687 -- arity excludes type args
1688 -> Just (ConVal (DataAlt con) args)
1690 _other | valArgCount args < idArity fun
1691 -- Under-applied function
1692 -> Just LambdaVal -- Partial application
1696 isValue _env _expr = Nothing
1698 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1699 mk_con_app (LitAlt lit) [] = Lit lit
1700 mk_con_app (DataAlt con) args = mkConApp con args
1701 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1703 samePat :: CallPat -> CallPat -> Bool
1704 samePat (vs1, as1) (vs2, as2)
1707 same (Var v1) (Var v2)
1708 | v1 `elem` vs1 = v2 `elem` vs2
1709 | v2 `elem` vs2 = False
1710 | otherwise = v1 == v2
1712 same (Lit l1) (Lit l2) = l1==l2
1713 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1715 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1716 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1717 same (Cast e1 _) e2 = same e1 e2
1718 same e1 (Note _ e2) = same e1 e2
1719 same e1 (Cast e2 _) = same e1 e2
1721 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1722 False -- Let, lambda, case should not occur
1723 bad (Case {}) = True
1729 Note [Ignore type differences]
1730 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1731 We do not want to generate specialisations where the call patterns
1732 differ only in their type arguments! Not only is it utterly useless,
1733 but it also means that (with polymorphic recursion) we can generate
1734 an infinite number of specialisations. Example is Data.Sequence.adjustTree,