2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SpecConstr]{Specialise over constructors}
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 , SpecConstrAnnotation(..)
20 #include "HsVersions.h"
25 import CoreUnfold ( couldBeSmallEnoughToInline )
26 import CoreFVs ( exprsFreeVars )
28 import HscTypes ( ModGuts(..) )
29 import WwLib ( mkWorkerArgs )
33 import Type hiding( substTy )
35 import MkCore ( mkImpossibleExpr )
41 import DynFlags ( DynFlags(..) )
42 import StaticFlags ( opt_PprStyle_Debug )
43 import Maybes ( orElse, catMaybes, isJust, isNothing )
45 import DmdAnal ( both )
46 import Serialized ( deserializeWithData )
53 import Control.Monad ( zipWithM )
57 -- See Note [SpecConstrAnnotation]
59 type SpecConstrAnnotation = ()
61 import Literal ( literalType )
62 import TyCon ( TyCon )
63 import GHC.Exts( SpecConstrAnnotation(..) )
67 -----------------------------------------------------
69 -----------------------------------------------------
74 drop n (x:xs) = drop (n-1) xs
76 After the first time round, we could pass n unboxed. This happens in
77 numerical code too. Here's what it looks like in Core:
79 drop n xs = case xs of
84 _ -> drop (I# (n# -# 1#)) xs
86 Notice that the recursive call has an explicit constructor as argument.
87 Noticing this, we can make a specialised version of drop
89 RULE: drop (I# n#) xs ==> drop' n# xs
91 drop' n# xs = let n = I# n# in ...orig RHS...
93 Now the simplifier will apply the specialisation in the rhs of drop', giving
95 drop' n# xs = case xs of
99 _ -> drop (n# -# 1#) xs
103 We'd also like to catch cases where a parameter is carried along unchanged,
104 but evaluated each time round the loop:
106 f i n = if i>0 || i>n then i else f (i*2) n
108 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
109 In Core, by the time we've w/wd (f is strict in i) we get
111 f i# n = case i# ># 0 of
113 True -> case n of n' { I# n# ->
116 True -> f (i# *# 2#) n'
118 At the call to f, we see that the argument, n is know to be (I# n#),
119 and n is evaluated elsewhere in the body of f, so we can play the same
125 We must be careful not to allocate the same constructor twice. Consider
126 f p = (...(case p of (a,b) -> e)...p...,
127 ...let t = (r,s) in ...t...(f t)...)
128 At the recursive call to f, we can see that t is a pair. But we do NOT want
129 to make a specialised copy:
130 f' a b = let p = (a,b) in (..., ...)
131 because now t is allocated by the caller, then r and s are passed to the
132 recursive call, which allocates the (r,s) pair again.
135 (a) the argument p is used in other than a case-scrutinsation way.
136 (b) the argument to the call is not a 'fresh' tuple; you have to
137 look into its unfolding to see that it's a tuple
139 Hence the "OR" part of Note [Good arguments] below.
141 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
142 allocation, but does perhaps save evals. In the RULE we'd have
145 f (I# x#) = f' (I# x#) x#
147 If at the call site the (I# x) was an unfolding, then we'd have to
148 rely on CSE to eliminate the duplicate allocation.... This alternative
149 doesn't look attractive enough to pursue.
151 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
152 the conservative reboxing story prevents many useful functions from being
153 specialised. Example:
154 foo :: Maybe Int -> Int -> Int
156 foo x@(Just m) n = foo x (n-m)
157 Here the use of 'x' will clearly not require boxing in the specialised function.
159 The strictness analyser has the same problem, in fact. Example:
161 If we pass just 'a' and 'b' to the worker, it might need to rebox the
162 pair to create (a,b). A more sophisticated analysis might figure out
163 precisely the cases in which this could happen, but the strictness
164 analyser does no such analysis; it just passes 'a' and 'b', and hopes
167 So my current choice is to make SpecConstr similarly aggressive, and
168 ignore the bad potential of reboxing.
171 Note [Good arguments]
172 ~~~~~~~~~~~~~~~~~~~~~
175 * A self-recursive function. Ignore mutual recursion for now,
176 because it's less common, and the code is simpler for self-recursion.
180 a) At a recursive call, one or more parameters is an explicit
181 constructor application
183 That same parameter is scrutinised by a case somewhere in
184 the RHS of the function
188 b) At a recursive call, one or more parameters has an unfolding
189 that is an explicit constructor application
191 That same parameter is scrutinised by a case somewhere in
192 the RHS of the function
194 Those are the only uses of the parameter (see Note [Reboxing])
197 What to abstract over
198 ~~~~~~~~~~~~~~~~~~~~~
199 There's a bit of a complication with type arguments. If the call
202 f p = ...f ((:) [a] x xs)...
204 then our specialised function look like
206 f_spec x xs = let p = (:) [a] x xs in ....as before....
208 This only makes sense if either
209 a) the type variable 'a' is in scope at the top of f, or
210 b) the type variable 'a' is an argument to f (and hence fs)
212 Actually, (a) may hold for value arguments too, in which case
213 we may not want to pass them. Supose 'x' is in scope at f's
214 defn, but xs is not. Then we'd like
216 f_spec xs = let p = (:) [a] x xs in ....as before....
218 Similarly (b) may hold too. If x is already an argument at the
219 call, no need to pass it again.
221 Finally, if 'a' is not in scope at the call site, we could abstract
222 it as we do the term variables:
224 f_spec a x xs = let p = (:) [a] x xs in ...as before...
226 So the grand plan is:
228 * abstract the call site to a constructor-only pattern
229 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
231 * Find the free variables of the abstracted pattern
233 * Pass these variables, less any that are in scope at
234 the fn defn. But see Note [Shadowing] below.
237 NOTICE that we only abstract over variables that are not in scope,
238 so we're in no danger of shadowing variables used in "higher up"
244 In this pass we gather up usage information that may mention variables
245 that are bound between the usage site and the definition site; or (more
246 seriously) may be bound to something different at the definition site.
249 f x = letrec g y v = let x = ...
252 Since 'x' is in scope at the call site, we may make a rewrite rule that
254 RULE forall a,b. g (a,b) x = ...
255 But this rule will never match, because it's really a different 'x' at
256 the call site -- and that difference will be manifest by the time the
257 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
258 no-shadowing, so perhaps it may not be distinct?]
260 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
261 is to run deShadowBinds before running SpecConstr, but instead we run the
262 simplifier. That gives the simplest possible program for SpecConstr to
263 chew on; and it virtually guarantees no shadowing.
265 Note [Specialising for constant parameters]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 This one is about specialising on a *constant* (but not necessarily
268 constructor) argument
270 foo :: Int -> (Int -> Int) -> Int
272 foo m f = foo (f m) (+1)
276 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
278 \ (ds_dlk :: GHC.Base.Int) ->
279 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
280 GHC.Base.I# (GHC.Prim.+# x_alG 1)
282 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
285 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
286 case ww_sme of ds_Xlw {
288 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
289 T.$wfoo ww1_Xmz lvl_rmV
294 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
295 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
297 When is this worth it? Call the constant 'lvl'
298 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
299 parameter is scrutinised anywhere in the body.
301 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
302 parameter is applied (...to enough arguments...?)
304 Also do this is if the function has RULES?
308 Note [Specialising for lambda parameters]
309 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
310 foo :: Int -> (Int -> Int) -> Int
312 foo m f = foo (f m) (\n -> n-m)
314 This is subtly different from the previous one in that we get an
315 explicit lambda as the argument:
317 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
320 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
321 case ww_sm8 of ds_Xlr {
323 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
326 (\ (n_ad3 :: GHC.Base.Int) ->
327 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
328 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
334 I wonder if SpecConstr couldn't be extended to handle this? After all,
335 lambda is a sort of constructor for functions and perhaps it already
336 has most of the necessary machinery?
338 Furthermore, there's an immediate win, because you don't need to allocate the lamda
339 at the call site; and if perchance it's called in the recursive call, then you
340 may avoid allocating it altogether. Just like for constructors.
342 Looks cool, but probably rare...but it might be easy to implement.
345 Note [SpecConstr for casts]
346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
349 data instance T Int = T Int
354 go (T n) = go (T (n-1))
356 The recursive call ends up looking like
357 go (T (I# ...) `cast` g)
358 So we want to spot the construtor application inside the cast.
359 That's why we have the Cast case in argToPat
361 Note [Local recursive groups]
362 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 For a *local* recursive group, we can see all the calls to the
364 function, so we seed the specialisation loop from the calls in the
365 body, not from the calls in the RHS. Consider:
367 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
371 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
372 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
373 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
374 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
376 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
377 most of which are not needed. But if we start with the (single) call
378 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
379 the recursive calls go to this fully-specialised copy. Indeed, the original
380 function is later collected as dead code. This is very important in
381 specialising the loops arising from stream fusion, for example in NDP where
382 we were getting literally hundreds of (mostly unused) specialisations of
385 Note [Do not specialise diverging functions]
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
387 Specialising a function that just diverges is a waste of code.
388 Furthermore, it broke GHC (simpl014) thus:
390 f = \x. case x of (a,b) -> f x
391 If we specialise f we get
392 f = \x. case x of (a,b) -> fspec a b
393 But fspec doesn't have decent strictnes info. As it happened,
394 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
395 and hence f. But now f's strictness is less than its arity, which
398 Note [SpecConstrAnnotation]
399 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
400 SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
401 be available in stage 2 (well, until the bootstrap compiler can be
402 guaranteed to have it)
404 So we define it to be () in stage1 (ie when GHCI is undefined), and
405 '#ifdef' out the code that uses it.
407 See also Note [Forcing specialisation]
409 Note [Forcing specialisation]
410 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
411 With stream fusion and in other similar cases, we want to fully specialise
412 some (but not necessarily all!) loops regardless of their size and the
413 number of specialisations. We allow a library to specify this by annotating
414 a type with ForceSpecConstr and then adding a parameter of that type to the
415 loop. Here is a (simplified) example from the vector library:
417 data SPEC = SPEC | SPEC2
418 {-# ANN type SPEC ForceSpecConstr #-}
420 foldl :: (a -> b -> a) -> a -> Stream b -> a
422 foldl f z (Stream step s _) = foldl_loop SPEC z s
424 foldl_loop !sPEC z s = case step s of
425 Yield x s' -> foldl_loop sPEC (f z x) s'
426 Skip -> foldl_loop sPEC z s'
429 SpecConstr will spot the SPEC parameter and always fully specialise
430 foldl_loop. Note that
432 * We have to prevent the SPEC argument from being removed by
433 w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
436 * And lastly, the SPEC argument is ultimately eliminated by
437 SpecConstr itself so there is no runtime overhead.
439 This is all quite ugly; we ought to come
440 up with a better design.
442 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
443 sc_force to True when calling specLoop. This flag makes specLoop and
444 specialise ignore specConstrCount and specConstrThreshold when deciding
445 whether to specialise a function. It also specialises even for arguments that
446 aren't inspected in the loop.
448 What alternatives did I consider? Annotating the loop itself doesn't
449 work because (a) it is local and (b) it will be w/w'ed and I having
450 w/w propagating annotation somehow doesn't seem like a good idea. The
451 types of the loop arguments really seem to be the most persistent
454 Annotating the types that make up the loop state s doesn't work,
455 either, because (a) it would prevent us from using types like Either
456 or tuples here, (b) we don't want to restrict the set of types that
457 can be used in Stream states and (c) some types are fixed by the user
458 (e.g., the accumulator here) but we still want to specialise as much
461 Alternatives to ForceSpecConstr
462 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
463 Instead of giving the loop an extra argument of type SPEC, we
464 also considered *wrapping* arguments in SPEC, thus
465 data SPEC a = SPEC a | SPEC2
467 loop = \arg -> case arg of
469 case state of (x,y) -> ... loop (SPEC (x',y')) ...
471 The idea is that a SPEC argument says "specialise this argument
472 regardless of whether the function case-analyses it. But this
474 * SPEC must still be a sum type, else the strictness analyser
476 * But that means that 'loop' won't be strict in its real payload
477 This loss of strictness in turn screws up specialisation, because
478 we may end up with calls like
479 loop (SPEC (case z of (p,q) -> (q,p)))
480 Without the SPEC, if 'loop' was strict, the case would move out
481 and we'd see loop applied to a pair. But if 'loop' isn' strict
482 this doesn't look like a specialisable call.
484 -----------------------------------------------------
485 Stuff not yet handled
486 -----------------------------------------------------
488 Here are notes arising from Roman's work that I don't want to lose.
494 foo :: Int -> T Int -> Int
496 foo x t | even x = case t of { T n -> foo (x-n) t }
497 | otherwise = foo (x-1) t
499 SpecConstr does no specialisation, because the second recursive call
500 looks like a boxed use of the argument. A pity.
502 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
504 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
505 case ww_sFo of ds_Xw6 [Just L] {
507 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
508 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
510 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
511 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
512 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
518 data a :*: b = !a :*: !b
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 Very similar to the previous one, except that the parameters are now in
527 a strict tuple. Before SpecConstr, we have
529 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
531 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
533 case ww_sFU of ds_Xws [Just L] {
535 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
537 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
538 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
541 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
542 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
543 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
547 We get two specialisations:
548 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
549 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
550 = Foo.$s$wfoo1 a_sFB sc_sGC ;
551 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
552 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
553 = Foo.$s$wfoo y_aFp sc_sGC ;
555 But perhaps the first one isn't good. After all, we know that tpl_B2 is
556 a T (I# x) really, because T is strict and Int has one constructor. (We can't
557 unbox the strict fields, becuase T is polymorphic!)
559 %************************************************************************
561 \subsection{Top level wrapper stuff}
563 %************************************************************************
566 specConstrProgram :: ModGuts -> CoreM ModGuts
567 specConstrProgram guts
569 dflags <- getDynFlags
570 us <- getUniqueSupplyM
571 annos <- getFirstAnnotations deserializeWithData guts
572 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
573 return (guts { mg_binds = binds' })
576 go env (bind:binds) = do (env', bind') <- scTopBind env bind
577 binds' <- go env' binds
578 return (bind' : binds')
582 %************************************************************************
584 \subsection{Environment: goes downwards}
586 %************************************************************************
589 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
590 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
591 -- See Note [Avoiding exponential blowup]
592 sc_force :: Bool, -- Force specialisation?
593 -- See Note [Forcing specialisation]
595 sc_subst :: Subst, -- Current substitution
596 -- Maps InIds to OutExprs
598 sc_how_bound :: HowBoundEnv,
599 -- Binds interesting non-top-level variables
600 -- Domain is OutVars (*after* applying the substitution)
603 -- Domain is OutIds (*after* applying the substitution)
604 -- Used even for top-level bindings (but not imported ones)
606 sc_annotations :: UniqFM SpecConstrAnnotation
609 ---------------------
610 -- As we go, we apply a substitution (sc_subst) to the current term
611 type InExpr = CoreExpr -- _Before_ applying the subst
614 type OutExpr = CoreExpr -- _After_ applying the subst
618 ---------------------
619 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
621 ---------------------
622 type ValueEnv = IdEnv Value -- Domain is OutIds
623 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
624 -- The AltCon is never DEFAULT
625 | LambdaVal -- Inlinable lambdas or PAPs
627 instance Outputable Value where
628 ppr (ConVal con args) = ppr con <+> interpp'SP args
629 ppr LambdaVal = ptext (sLit "<Lambda>")
631 ---------------------
632 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
633 initScEnv dflags anns
634 = SCE { sc_size = specConstrThreshold dflags,
635 sc_count = specConstrCount dflags,
637 sc_subst = emptySubst,
638 sc_how_bound = emptyVarEnv,
639 sc_vals = emptyVarEnv,
640 sc_annotations = anns }
642 data HowBound = RecFun -- These are the recursive functions for which
643 -- we seek interesting call patterns
645 | RecArg -- These are those functions' arguments, or their sub-components;
646 -- we gather occurrence information for these
648 instance Outputable HowBound where
649 ppr RecFun = text "RecFun"
650 ppr RecArg = text "RecArg"
652 scForce :: ScEnv -> Bool -> ScEnv
653 scForce env b = env { sc_force = b }
655 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
656 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
658 scSubstId :: ScEnv -> Id -> CoreExpr
659 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
661 scSubstTy :: ScEnv -> Type -> Type
662 scSubstTy env ty = substTy (sc_subst env) ty
664 zapScSubst :: ScEnv -> ScEnv
665 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
667 extendScInScope :: ScEnv -> [Var] -> ScEnv
668 -- Bring the quantified variables into scope
669 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
671 -- Extend the substitution
672 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
673 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
675 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
676 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
678 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
679 extendHowBound env bndrs how_bound
680 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
681 [(bndr,how_bound) | bndr <- bndrs] }
683 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
684 extendBndrsWith how_bound env bndrs
685 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
687 (subst', bndrs') = substBndrs (sc_subst env) bndrs
688 hb_env' = sc_how_bound env `extendVarEnvList`
689 [(bndr,how_bound) | bndr <- bndrs']
691 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
692 extendBndrWith how_bound env bndr
693 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
695 (subst', bndr') = substBndr (sc_subst env) bndr
696 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
698 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
699 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
701 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
703 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
704 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
706 (subst', bndr') = substBndr (sc_subst env) bndr
708 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
709 extendValEnv env _ Nothing = env
710 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
712 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
716 -- we want to bind b, to (C x y)
717 -- NB1: Extends only the sc_vals part of the envt
718 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
719 -- they are potentially made alive by the [b -> C x y] binding
720 extendCaseBndrs env case_bndr con alt_bndrs
721 | isDeadBinder case_bndr
724 = (env1, map zap alt_bndrs)
725 -- NB: We used to bind v too, if scrut = (Var v); but
726 -- the simplifer has already done this so it seems
727 -- redundant to do so here
729 -- Var v -> extendValEnv env1 v cval
732 zap v | isTyCoVar v = v -- See NB2 above
733 | otherwise = zapIdOccInfo v
734 env1 = extendValEnv env case_bndr cval
737 LitAlt {} -> Just (ConVal con [])
738 DataAlt {} -> Just (ConVal con vanilla_args)
740 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
741 varsToCoreExprs alt_bndrs
744 decreaseSpecCount :: ScEnv -> Int -> ScEnv
745 -- See Note [Avoiding exponential blowup]
746 decreaseSpecCount env n_specs
747 = env { sc_count = case sc_count env of
749 Just n -> Just (n `div` (n_specs + 1)) }
750 -- The "+1" takes account of the original function;
751 -- See Note [Avoiding exponential blowup]
753 ---------------------------------------------------
754 -- See Note [SpecConstrAnnotation]
755 ignoreType :: ScEnv -> Type -> Bool
756 ignoreAltCon :: ScEnv -> AltCon -> Bool
757 forceSpecBndr :: ScEnv -> Var -> Bool
759 ignoreType _ _ = False
760 ignoreAltCon _ _ = False
761 forceSpecBndr _ _ = False
765 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
766 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
767 ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal
770 = case splitTyConApp_maybe ty of
771 Just (tycon, _) -> ignoreTyCon env tycon
774 ignoreTyCon :: ScEnv -> TyCon -> Bool
775 ignoreTyCon env tycon
776 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
778 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
780 forceSpecFunTy :: ScEnv -> Type -> Bool
781 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
783 forceSpecArgTy :: ScEnv -> Type -> Bool
784 forceSpecArgTy env ty
785 | Just ty' <- coreView ty = forceSpecArgTy env ty'
787 forceSpecArgTy env ty
788 | Just (tycon, tys) <- splitTyConApp_maybe ty
790 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
791 || any (forceSpecArgTy env) tys
793 forceSpecArgTy _ _ = False
797 Note [Avoiding exponential blowup]
798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
799 The sc_count field of the ScEnv says how many times we are prepared to
800 duplicate a single function. But we must take care with recursive
801 specialiations. Consider
803 let $j1 = let $j2 = let $j3 = ...
811 If we specialise $j1 then in each specialisation (as well as the original)
812 we can specialise $j2, and similarly $j3. Even if we make just *one*
813 specialisation of each, becuase we also have the original we'll get 2^n
814 copies of $j3, which is not good.
816 So when recursively specialising we divide the sc_count by the number of
817 copies we are making at this level, including the original.
820 %************************************************************************
822 \subsection{Usage information: flows upwards}
824 %************************************************************************
829 scu_calls :: CallEnv, -- Calls
830 -- The functions are a subset of the
831 -- RecFuns in the ScEnv
833 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
834 } -- The domain is OutIds
836 type CallEnv = IdEnv [Call]
837 type Call = (ValueEnv, [CoreArg])
838 -- The arguments of the call, together with the
839 -- env giving the constructor bindings at the call site
842 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
844 combineCalls :: CallEnv -> CallEnv -> CallEnv
845 combineCalls = plusVarEnv_C (++)
847 combineUsage :: ScUsage -> ScUsage -> ScUsage
848 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
849 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
851 combineUsages :: [ScUsage] -> ScUsage
852 combineUsages [] = nullUsage
853 combineUsages us = foldr1 combineUsage us
855 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
856 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
857 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
858 lookupVarEnv sc_occs bndr `orElse` NoOcc)
860 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
861 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
862 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
863 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
865 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
866 | UnkOcc -- Used in some unknown way
868 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
870 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
874 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
875 is *only* taken apart or applied.
877 Functions, literal: ScrutOcc emptyUFM
878 Data constructors: ScrutOcc subs,
880 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
881 The domain of the UniqFM is the Unique of the data constructor
883 The [ArgOcc] is the occurrences of the *pattern-bound* components
884 of the data structure. E.g.
885 data T a = forall b. MkT a b (b->a)
886 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
890 instance Outputable ArgOcc where
891 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
892 ppr UnkOcc = ptext (sLit "unk-occ")
893 ppr BothOcc = ptext (sLit "both-occ")
894 ppr NoOcc = ptext (sLit "no-occ")
896 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
897 -- that if the thing is scrutinised anywhere then we get to see that
898 -- in the overall result, even if it's also used in a boxed way
899 -- This might be too agressive; see Note [Reboxing] Alternative 3
900 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
901 combineOcc NoOcc occ = occ
902 combineOcc occ NoOcc = occ
903 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
904 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
905 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
906 combineOcc UnkOcc UnkOcc = UnkOcc
907 combineOcc _ _ = BothOcc
909 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
910 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
912 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
913 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
914 -- is a variable, and an interesting variable
915 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
916 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
917 setScrutOcc env usg (Var v) occ
918 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
920 setScrutOcc _env usg _other _occ -- Catch-all
923 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
924 -- Find usage of components of data con; returns [UnkOcc...] if unknown
925 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
927 conArgOccs (ScrutOcc fm) (DataAlt dc)
928 | Just pat_arg_occs <- lookupUFM fm dc
929 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
931 conArgOccs _other _con = repeat UnkOcc
934 %************************************************************************
936 \subsection{The main recursive function}
938 %************************************************************************
940 The main recursive function gathers up usage information, and
941 creates specialised versions of functions.
944 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
945 -- The unique supply is needed when we invent
946 -- a new name for the specialised function and its args
948 scExpr env e = scExpr' env e
951 scExpr' env (Var v) = case scSubstId env v of
952 Var v' -> return (varUsage env v' UnkOcc, Var v')
953 e' -> scExpr (zapScSubst env) e'
955 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
956 scExpr' _ e@(Lit {}) = return (nullUsage, e)
957 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
958 return (usg, Note n e')
959 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
960 return (usg, Cast e' (scSubstTy env co))
961 scExpr' env e@(App _ _) = scApp env (collectArgs e)
962 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
963 (usg, e') <- scExpr env' e
964 return (usg, Lam b' e')
966 scExpr' env (Case scrut b ty alts)
967 = do { (scrut_usg, scrut') <- scExpr env scrut
968 ; case isValue (sc_vals env) scrut' of
969 Just (ConVal con args) -> sc_con_app con args scrut'
970 _other -> sc_vanilla scrut_usg scrut'
973 sc_con_app con args scrut' -- Known constructor; simplify
974 = do { let (_, bs, rhs) = findAlt con alts
975 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
976 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
977 ; scExpr alt_env' rhs }
979 sc_vanilla scrut_usg scrut' -- Normal case
980 = do { let (alt_env,b') = extendBndrWith RecArg env b
981 -- Record RecArg for the components
983 ; (alt_usgs, alt_occs, alts')
984 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
986 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
987 scrut_occ = foldr combineOcc b_occ alt_occs
988 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
989 -- The combined usage of the scrutinee is given
990 -- by scrut_occ, which is passed to scScrut, which
991 -- in turn treats a bare-variable scrutinee specially
993 ; return (alt_usg `combineUsage` scrut_usg',
994 Case scrut' b' (scSubstTy env ty) alts') }
996 sc_alt env _scrut' b' (con,bs,rhs)
997 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
998 (env2, bs2) = extendCaseBndrs env1 b' con bs1
999 ; (usg,rhs') <- scExpr env2 rhs
1000 ; let (usg', arg_occs) = lookupOccs usg bs2
1001 scrut_occ = case con of
1002 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
1003 _ -> ScrutOcc emptyUFM
1004 ; return (usg', scrut_occ, (con, bs2, rhs')) }
1006 scExpr' env (Let (NonRec bndr rhs) body)
1007 | isTyCoVar bndr -- Type-lets may be created by doBeta
1008 = scExpr' (extendScSubst env bndr rhs) body
1011 = do { let (body_env, bndr') = extendBndr env bndr
1012 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
1014 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
1015 -- Note [Local let bindings]
1016 RI _ rhs' _ _ _ = rhs_info
1017 body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
1019 ; (body_usg, body') <- scExpr body_env3 body
1021 -- NB: We don't use the ForceSpecConstr mechanism (see
1022 -- Note [Forcing specialisation]) for non-recursive bindings
1023 -- at the moment. I'm not sure if this is the right thing to do.
1024 ; let env' = scForce env False
1025 ; (spec_usg, specs) <- specialise env'
1026 (scu_calls body_usg)
1028 (SI [] 0 (Just rhs_usg))
1030 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1031 `combineUsage` spec_usg,
1032 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1036 -- A *local* recursive group: see Note [Local recursive groups]
1037 scExpr' env (Let (Rec prs) body)
1038 = do { let (bndrs,rhss) = unzip prs
1039 (rhs_env1,bndrs') = extendRecBndrs env bndrs
1040 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1041 force_spec = any (forceSpecBndr env) bndrs'
1042 -- Note [Forcing specialisation]
1044 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1045 ; (body_usg, body') <- scExpr rhs_env2 body
1047 -- NB: start specLoop from body_usg
1048 ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
1049 (scu_calls body_usg) rhs_infos nullUsage
1050 [SI [] 0 (Just usg) | usg <- rhs_usgs]
1051 -- Do not unconditionally use rhs_usgs.
1052 -- Instead use them only if we find an unspecialised call
1053 -- See Note [Local recursive groups]
1055 ; let all_usg = spec_usg `combineUsage` body_usg
1056 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1058 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1062 Note [Local let bindings]
1063 ~~~~~~~~~~~~~~~~~~~~~~~~~
1064 It is not uncommon to find this
1066 let $j = \x. <blah> in ...$j True...$j True...
1068 Here $j is an arbitrary let-bound function, but it often comes up for
1069 join points. We might like to specialise $j for its call patterns.
1070 Notice the difference from a letrec, where we look for call patterns
1071 in the *RHS* of the function. Here we look for call patterns in the
1074 At one point I predicated this on the RHS mentioning the outer
1075 recursive function, but that's not essential and might even be
1076 harmful. I'm not sure.
1080 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1082 scApp env (Var fn, args) -- Function is a variable
1083 = ASSERT( not (null args) )
1084 do { args_w_usgs <- mapM (scExpr env) args
1085 ; let (arg_usgs, args') = unzip args_w_usgs
1086 arg_usg = combineUsages arg_usgs
1087 ; case scSubstId env fn of
1088 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1089 -- Do beta-reduction and try again
1091 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1093 fn_usg = case lookupHowBound env fn' of
1094 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
1095 scu_occs = emptyVarEnv }
1096 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1097 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
1098 Nothing -> nullUsage
1101 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1102 -- NB: doing this ignores any usage info from the substituted
1103 -- function, but I don't think that matters. If it does
1106 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1107 -- ToDo: adjust for System IF
1108 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1109 doBeta fn args = mkApps fn args
1111 -- The function is almost always a variable, but not always.
1112 -- In particular, if this pass follows float-in,
1113 -- which it may, we can get
1114 -- (let f = ...f... in f) arg1 arg2
1115 scApp env (other_fn, args)
1116 = do { (fn_usg, fn') <- scExpr env other_fn
1117 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1118 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1120 ----------------------
1121 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1122 scTopBind env (Rec prs)
1123 | Just threshold <- sc_size env
1125 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1126 -- No specialisation
1127 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1128 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1129 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1130 | otherwise -- Do specialisation
1131 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1132 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1134 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1135 ; let rhs_usg = combineUsages rhs_usgs
1137 ; (_, specs) <- specLoop (scForce rhs_env2 force_spec)
1138 (scu_calls rhs_usg) rhs_infos nullUsage
1139 [SI [] 0 Nothing | _ <- bndrs]
1141 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1142 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1144 (bndrs,rhss) = unzip prs
1145 force_spec = any (forceSpecBndr env) bndrs
1146 -- Note [Forcing specialisation]
1148 scTopBind env (NonRec bndr rhs)
1149 = do { (_, rhs') <- scExpr env rhs
1150 ; let (env1, bndr') = extendBndr env bndr
1151 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1152 ; return (env2, NonRec bndr' rhs') }
1154 ----------------------
1155 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1156 scRecRhs env (bndr,rhs)
1157 = do { let (arg_bndrs,body) = collectBinders rhs
1158 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1159 ; (body_usg, body') <- scExpr body_env body
1160 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1161 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1162 arg_bndrs body arg_occs) }
1163 -- The arg_occs says how the visible,
1164 -- lambda-bound binders of the RHS are used
1165 -- (including the TyVar binders)
1166 -- Two pats are the same if they match both ways
1168 ----------------------
1169 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1170 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1171 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1172 [(fn `addIdSpecialisations` rules, new_rhs)]
1174 rules = [r | OS _ r _ _ <- specs]
1176 ----------------------
1177 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1179 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1180 , scu_occs = unitVarEnv v use }
1181 | otherwise = nullUsage
1185 %************************************************************************
1187 The specialiser itself
1189 %************************************************************************
1192 data RhsInfo = RI OutId -- The binder
1193 OutExpr -- The new RHS
1194 [InVar] InExpr -- The *original* RHS (\xs.body)
1195 -- Note [Specialise original body]
1196 [ArgOcc] -- Info on how the xs occur in body
1198 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1200 Int -- Length of specs; used for numbering them
1202 (Maybe ScUsage) -- Nothing => we have generated specialisations
1203 -- from calls in the *original* RHS
1204 -- Just cs => we haven't, and this is the usage
1205 -- of the original RHS
1206 -- See Note [Local recursive groups]
1208 -- One specialisation: Rule plus definition
1209 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1210 CoreRule -- Rule connecting original id with the specialisation
1211 OutId OutExpr -- Spec id + its rhs
1217 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1218 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1219 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1220 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1221 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1222 new_usg = combineUsages new_usg_s
1223 new_calls = scu_calls new_usg
1224 all_usg = usg_so_far `combineUsage` new_usg
1225 ; if isEmptyVarEnv new_calls then
1226 return (all_usg, all_specs)
1228 specLoop env new_calls rhs_infos all_usg all_specs }
1232 -> CallEnv -- Info on calls
1234 -> SpecInfo -- Original RHS plus patterns dealt with
1235 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1237 -- Note: the rhs here is the optimised version of the original rhs
1238 -- So when we make a specialised copy of the RHS, we're starting
1239 -- from an RHS whose nested functions have been optimised already.
1241 specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
1242 spec_info@(SI specs spec_count mb_unspec)
1243 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1244 , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1245 , notNull arg_bndrs -- Only specialise functions
1246 , Just all_calls <- lookupVarEnv bind_calls fn
1247 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1248 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1249 -- , text "arg_occs" <+> ppr arg_occs
1250 -- , text "calls" <+> ppr all_calls
1251 -- , text "good pats" <+> ppr pats]) $
1254 -- Bale out if too many specialisations
1255 ; let n_pats = length pats
1256 spec_count' = n_pats + spec_count
1257 ; case sc_count env of
1258 Just max | not (sc_force env) && spec_count' > max
1259 -> pprTrace "SpecConstr" msg $
1260 return (nullUsage, spec_info)
1262 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1263 , nest 2 (ptext (sLit "has") <+>
1264 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1265 ptext (sLit "but the limit is") <+> int max) ]
1266 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1268 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1269 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1271 _normal_case -> do {
1273 let spec_env = decreaseSpecCount env n_pats
1274 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1275 (pats `zip` [spec_count..])
1276 -- See Note [Specialise original body]
1278 ; let spec_usg = combineUsages spec_usgs
1279 (new_usg, mb_unspec')
1281 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1282 _ -> (spec_usg, mb_unspec)
1284 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1286 = return (nullUsage, spec_info) -- The boring case
1289 ---------------------
1291 -> OutId -- Function
1292 -> [InVar] -- Lambda-binders of RHS; should match patterns
1293 -> InExpr -- Body of the original function
1295 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1297 -- spec_one creates a specialised copy of the function, together
1298 -- with a rule for using it. I'm very proud of how short this
1299 -- function is, considering what it does :-).
1305 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1306 [c::*, v::(b,c) are presumably bound by the (...) part]
1308 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1309 (...entire body of f...) [b -> (b,c),
1310 y -> ((:) (a,(b,c)) (x,v) hw)]
1312 RULE: forall b::* c::*, -- Note, *not* forall a, x
1316 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1319 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1320 = do { spec_uniq <- getUniqueUs
1321 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1322 (arg_bndrs `zip` pats)
1324 fn_loc = nameSrcSpan fn_name
1325 spec_occ = mkSpecOcc (nameOccName fn_name)
1326 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1327 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1328 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1331 -- Specialise the body
1332 ; (spec_usg, spec_body) <- scExpr spec_env body
1334 -- ; pprTrace "done spec_one}" (ppr fn) $
1337 -- And build the results
1338 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1339 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1340 `setIdArity` count isId spec_lam_args
1341 spec_str = calcSpecStrictness fn spec_lam_args pats
1342 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1343 -- Usual w/w hack to avoid generating
1344 -- a spec_rhs of unlifted type and no args
1346 spec_rhs = mkLams spec_lam_args spec_body
1347 body_ty = exprType spec_body
1348 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1349 inline_act = idInlineActivation fn
1350 rule = mkRule True {- Auto -} True {- Local -}
1351 rule_name inline_act fn_name qvars pats rule_rhs
1352 -- See Note [Transfer activation]
1353 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1355 calcSpecStrictness :: Id -- The original function
1356 -> [Var] -> [CoreExpr] -- Call pattern
1357 -> StrictSig -- Strictness of specialised thing
1358 -- See Note [Transfer strictness]
1359 calcSpecStrictness fn qvars pats
1360 = StrictSig (mkTopDmdType spec_dmds TopRes)
1362 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1363 StrictSig (DmdType _ dmds _) = idStrictness fn
1365 dmd_env = go emptyVarEnv dmds pats
1367 go env ds (Type {} : pats) = go env ds pats
1368 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1371 go_one env d (Var v) = extendVarEnv_C both env v d
1372 go_one env (Box d) e = go_one env d e
1373 go_one env (Eval (Prod ds)) e
1374 | (Var _, args) <- collectArgs e = go env ds args
1375 go_one env _ _ = env
1379 Note [Specialise original body]
1380 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1381 The RhsInfo for a binding keeps the *original* body of the binding. We
1382 must specialise that, *not* the result of applying specExpr to the RHS
1383 (which is also kept in RhsInfo). Otherwise we end up specialising a
1384 specialised RHS, and that can lead directly to exponential behaviour.
1386 Note [Transfer activation]
1387 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1388 This note is for SpecConstr, but exactly the same thing
1389 happens in the overloading specialiser; see
1390 Note [Auto-specialisation and RULES] in Specialise.
1392 In which phase should the specialise-constructor rules be active?
1393 Originally I made them always-active, but Manuel found that this
1394 defeated some clever user-written rules. Then I made them active only
1395 in Phase 0; after all, currently, the specConstr transformation is
1396 only run after the simplifier has reached Phase 0, but that meant
1397 that specialisations didn't fire inside wrappers; see test
1398 simplCore/should_compile/spec-inline.
1400 So now I just use the inline-activation of the parent Id, as the
1401 activation for the specialiation RULE, just like the main specialiser;
1403 This in turn means there is no point in specialising NOINLINE things,
1404 so we test for that.
1406 Note [Transfer strictness]
1407 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1408 We must transfer strictness information from the original function to
1409 the specialised one. Suppose, for example
1412 and a RULE f (a:as) b = f_spec a as b
1414 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1415 when calling f_spec instead of call-by-value. And that can result in
1416 unbounded worsening in space (cf the classic foldl vs foldl')
1418 See Trac #3437 for a good example.
1420 The function calcSpecStrictness performs the calculation.
1423 %************************************************************************
1425 \subsection{Argument analysis}
1427 %************************************************************************
1429 This code deals with analysing call-site arguments to see whether
1430 they are constructor applications.
1434 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1437 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1438 -- Result has no duplicate patterns,
1439 -- nor ones mentioned in done_pats
1440 -- Bool indicates that there was at least one boring pattern
1441 callsToPats env done_specs bndr_occs calls
1442 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1444 ; let good_pats :: [([Var], [CoreArg])]
1445 good_pats = catMaybes mb_pats
1446 done_pats = [p | OS p _ _ _ <- done_specs]
1447 is_done p = any (samePat p) done_pats
1449 ; return (any isNothing mb_pats,
1450 filterOut is_done (nubBy samePat good_pats)) }
1452 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1453 -- The [Var] is the variables to quantify over in the rule
1454 -- Type variables come first, since they may scope
1455 -- over the following term variables
1456 -- The [CoreExpr] are the argument patterns for the rule
1457 callToPats env bndr_occs (con_env, args)
1458 | length args < length bndr_occs -- Check saturated
1461 = do { let in_scope = substInScope (sc_subst env)
1462 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1463 ; let (interesting_s, pats) = unzip prs
1464 pat_fvs = varSetElems (exprsFreeVars pats)
1465 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1466 -- Quantify over variables that are not in sccpe
1468 -- See Note [Shadowing] at the top
1470 (tvs, ids) = partition isTyCoVar qvars
1472 -- Put the type variables first; the type of a term
1473 -- variable may mention a type variable
1475 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1477 then return (Just (qvars', pats))
1478 else return Nothing }
1480 -- argToPat takes an actual argument, and returns an abstracted
1481 -- version, consisting of just the "constructor skeleton" of the
1482 -- argument, with non-constructor sub-expression replaced by new
1483 -- placeholder variables. For example:
1484 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1487 -> InScopeSet -- What's in scope at the fn defn site
1488 -> ValueEnv -- ValueEnv at the call site
1489 -> CoreArg -- A call arg (or component thereof)
1491 -> UniqSM (Bool, CoreArg)
1492 -- Returns (interesting, pat),
1493 -- where pat is the pattern derived from the argument
1494 -- intersting=True if the pattern is non-trivial (not a variable or type)
1495 -- E.g. x:xs --> (True, x:xs)
1496 -- f xs --> (False, w) where w is a fresh wildcard
1497 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1498 -- \x. x+y --> (True, \x. x+y)
1499 -- lvl7 --> (True, lvl7) if lvl7 is bound
1500 -- somewhere further out
1502 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1503 = return (False, arg)
1505 argToPat env in_scope val_env (Note _ arg) arg_occ
1506 = argToPat env in_scope val_env arg arg_occ
1507 -- Note [Notes in call patterns]
1508 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1509 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1510 -- Perhaps we should not ignore profiling notes, but I'm going to
1511 -- ride roughshod over them all for now.
1512 --- See Note [Notes in RULE matching] in Rules
1514 argToPat env in_scope val_env (Let _ arg) arg_occ
1515 = argToPat env in_scope val_env arg arg_occ
1516 -- See Note [Matching lets] in Rule.lhs
1517 -- Look through let expressions
1518 -- e.g. f (let v = rhs in (v,w))
1519 -- Here we can specialise for f (v,w)
1520 -- because the rule-matcher will look through the let.
1522 {- Disabled; see Note [Matching cases] in Rule.lhs
1523 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1524 | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
1525 = argToPat env in_scope val_env rhs arg_occ
1528 argToPat env in_scope val_env (Cast arg co) arg_occ
1529 | not (ignoreType env ty2)
1530 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1531 ; if not interesting then
1534 { -- Make a wild-card pattern for the coercion
1536 ; let co_name = mkSysTvName uniq (fsLit "sg")
1537 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1538 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1540 (ty1, ty2) = coercionKind co
1544 {- Disabling lambda specialisation for now
1545 It's fragile, and the spec_loop can be infinite
1546 argToPat in_scope val_env arg arg_occ
1548 = return (True, arg)
1550 is_value_lam (Lam v e) -- Spot a value lambda, even if
1551 | isId v = True -- it is inside a type lambda
1552 | otherwise = is_value_lam e
1553 is_value_lam other = False
1556 -- Check for a constructor application
1557 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1558 argToPat env in_scope val_env arg arg_occ
1559 | Just (ConVal dc args) <- isValue val_env arg
1560 , not (ignoreAltCon env dc)
1561 , sc_force env || scrutinised
1562 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1563 ; return (True, mk_con_app dc (map snd args')) }
1567 ScrutOcc _ -> True -- Used only by case scrutinee
1568 BothOcc -> case arg of -- Used elsewhere
1569 App {} -> True -- see Note [Reboxing]
1571 _other -> False -- No point; the arg is not decomposed
1574 -- Check if the argument is a variable that
1575 -- is in scope at the function definition site
1576 -- It's worth specialising on this if
1577 -- (a) it's used in an interesting way in the body
1578 -- (b) we know what its value is
1579 argToPat env in_scope val_env (Var v) arg_occ
1580 | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1582 not (ignoreType env (varType v))
1583 = return (True, Var v)
1586 | isLocalId v = v `elemInScopeSet` in_scope
1587 && isJust (lookupVarEnv val_env v)
1588 -- Local variables have values in val_env
1589 | otherwise = isValueUnfolding (idUnfolding v)
1590 -- Imports have unfoldings
1592 -- I'm really not sure what this comment means
1593 -- And by not wild-carding we tend to get forall'd
1594 -- variables that are in soope, which in turn can
1595 -- expose the weakness in let-matching
1596 -- See Note [Matching lets] in Rules
1598 -- Check for a variable bound inside the function.
1599 -- Don't make a wild-card, because we may usefully share
1600 -- e.g. f a = let x = ... in f (x,x)
1601 -- NB: this case follows the lambda and con-app cases!!
1602 -- argToPat _in_scope _val_env (Var v) _arg_occ
1603 -- = return (False, Var v)
1604 -- SLPJ : disabling this to avoid proliferation of versions
1605 -- also works badly when thinking about seeding the loop
1606 -- from the body of the let
1607 -- f x y = letrec g z = ... in g (x,y)
1608 -- We don't want to specialise for that *particular* x,y
1610 -- The default case: make a wild-card
1611 argToPat _env _in_scope _val_env arg _arg_occ
1612 = wildCardPat (exprType arg)
1614 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1615 wildCardPat ty = do { uniq <- getUniqueUs
1616 ; let id = mkSysLocal (fsLit "sc") uniq ty
1617 ; return (False, Var id) }
1619 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1620 -> [(CoreArg, ArgOcc)]
1621 -> UniqSM [(Bool, CoreArg)]
1622 argsToPats env in_scope val_env args
1625 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1630 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1631 isValue _env (Lit lit)
1632 = Just (ConVal (LitAlt lit) [])
1635 | Just stuff <- lookupVarEnv env v
1636 = Just stuff -- You might think we could look in the idUnfolding here
1637 -- but that doesn't take account of which branch of a
1638 -- case we are in, which is the whole point
1640 | not (isLocalId v) && isCheapUnfolding unf
1641 = isValue env (unfoldingTemplate unf)
1644 -- However we do want to consult the unfolding
1645 -- as well, for let-bound constructors!
1647 isValue env (Lam b e)
1648 | isTyCoVar b = case isValue env e of
1649 Just _ -> Just LambdaVal
1651 | otherwise = Just LambdaVal
1653 isValue _env expr -- Maybe it's a constructor application
1654 | (Var fun, args) <- collectArgs expr
1655 = case isDataConWorkId_maybe fun of
1657 Just con | args `lengthAtLeast` dataConRepArity con
1658 -- Check saturated; might be > because the
1659 -- arity excludes type args
1660 -> Just (ConVal (DataAlt con) args)
1662 _other | valArgCount args < idArity fun
1663 -- Under-applied function
1664 -> Just LambdaVal -- Partial application
1668 isValue _env _expr = Nothing
1670 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1671 mk_con_app (LitAlt lit) [] = Lit lit
1672 mk_con_app (DataAlt con) args = mkConApp con args
1673 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1675 samePat :: CallPat -> CallPat -> Bool
1676 samePat (vs1, as1) (vs2, as2)
1679 same (Var v1) (Var v2)
1680 | v1 `elem` vs1 = v2 `elem` vs2
1681 | v2 `elem` vs2 = False
1682 | otherwise = v1 == v2
1684 same (Lit l1) (Lit l2) = l1==l2
1685 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1687 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1688 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1689 same (Cast e1 _) e2 = same e1 e2
1690 same e1 (Note _ e2) = same e1 e2
1691 same e1 (Cast e2 _) = same e1 e2
1693 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1694 False -- Let, lambda, case should not occur
1695 bad (Case {}) = True
1701 Note [Ignore type differences]
1702 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1703 We do not want to generate specialisations where the call patterns
1704 differ only in their type arguments! Not only is it utterly useless,
1705 but it also means that (with polymorphic recursion) we can generate
1706 an infinite number of specialisations. Example is Data.Sequence.adjustTree,