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 force_spec to True when calling specLoop. This flag makes specLoop and
444 specialise ignore specConstrCount and specConstrThreshold when deciding
445 whether to specialise a function.
447 What alternatives did I consider? Annotating the loop itself doesn't
448 work because (a) it is local and (b) it will be w/w'ed and I having
449 w/w propagating annotation somehow doesn't seem like a good idea. The
450 types of the loop arguments really seem to be the most persistent
453 Annotating the types that make up the loop state s doesn't work,
454 either, because (a) it would prevent us from using types like Either
455 or tuples here, (b) we don't want to restrict the set of types that
456 can be used in Stream states and (c) some types are fixed by the user
457 (e.g., the accumulator here) but we still want to specialise as much
460 Alternatives to ForceSpecConstr
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462 Instead of giving the loop an extra argument of type SPEC, we
463 also considered *wrapping* arguments in SPEC, thus
464 data SPEC a = SPEC a | SPEC2
466 loop = \arg -> case arg of
468 case state of (x,y) -> ... loop (SPEC (x',y')) ...
470 The idea is that a SPEC argument says "specialise this argument
471 regardless of whether the function case-analyses it. But this
473 * SPEC must still be a sum type, else the strictness analyser
475 * But that means that 'loop' won't be strict in its real payload
476 This loss of strictness in turn screws up specialisation, because
477 we may end up with calls like
478 loop (SPEC (case z of (p,q) -> (q,p)))
479 Without the SPEC, if 'loop' was strict, the case would move out
480 and we'd see loop applied to a pair. But if 'loop' isn' strict
481 this doesn't look like a specialisable call.
483 -----------------------------------------------------
484 Stuff not yet handled
485 -----------------------------------------------------
487 Here are notes arising from Roman's work that I don't want to lose.
493 foo :: Int -> T Int -> Int
495 foo x t | even x = case t of { T n -> foo (x-n) t }
496 | otherwise = foo (x-1) t
498 SpecConstr does no specialisation, because the second recursive call
499 looks like a boxed use of the argument. A pity.
501 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
503 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
504 case ww_sFo of ds_Xw6 [Just L] {
506 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
507 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
509 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
510 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
511 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
517 data a :*: b = !a :*: !b
520 foo :: (Int :*: T Int) -> Int
522 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
523 | otherwise = foo ((x-1) :*: t)
525 Very similar to the previous one, except that the parameters are now in
526 a strict tuple. Before SpecConstr, we have
528 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
530 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
532 case ww_sFU of ds_Xws [Just L] {
534 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
536 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
537 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
540 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
541 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
542 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
546 We get two specialisations:
547 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
548 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
549 = Foo.$s$wfoo1 a_sFB sc_sGC ;
550 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
551 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
552 = Foo.$s$wfoo y_aFp sc_sGC ;
554 But perhaps the first one isn't good. After all, we know that tpl_B2 is
555 a T (I# x) really, because T is strict and Int has one constructor. (We can't
556 unbox the strict fields, becuase T is polymorphic!)
558 %************************************************************************
560 \subsection{Top level wrapper stuff}
562 %************************************************************************
565 specConstrProgram :: ModGuts -> CoreM ModGuts
566 specConstrProgram guts
568 dflags <- getDynFlags
569 us <- getUniqueSupplyM
570 annos <- getFirstAnnotations deserializeWithData guts
571 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
572 return (guts { mg_binds = binds' })
575 go env (bind:binds) = do (env', bind') <- scTopBind env bind
576 binds' <- go env' binds
577 return (bind' : binds')
581 %************************************************************************
583 \subsection{Environment: goes downwards}
585 %************************************************************************
588 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
589 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
590 -- See Note [Avoiding exponential blowup]
592 sc_subst :: Subst, -- Current substitution
593 -- Maps InIds to OutExprs
595 sc_how_bound :: HowBoundEnv,
596 -- Binds interesting non-top-level variables
597 -- Domain is OutVars (*after* applying the substitution)
600 -- Domain is OutIds (*after* applying the substitution)
601 -- Used even for top-level bindings (but not imported ones)
603 sc_annotations :: UniqFM SpecConstrAnnotation
606 ---------------------
607 -- As we go, we apply a substitution (sc_subst) to the current term
608 type InExpr = CoreExpr -- _Before_ applying the subst
611 type OutExpr = CoreExpr -- _After_ applying the subst
615 ---------------------
616 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
618 ---------------------
619 type ValueEnv = IdEnv Value -- Domain is OutIds
620 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
621 -- The AltCon is never DEFAULT
622 | LambdaVal -- Inlinable lambdas or PAPs
624 instance Outputable Value where
625 ppr (ConVal con args) = ppr con <+> interpp'SP args
626 ppr LambdaVal = ptext (sLit "<Lambda>")
628 ---------------------
629 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
630 initScEnv dflags anns
631 = SCE { sc_size = specConstrThreshold dflags,
632 sc_count = specConstrCount dflags,
633 sc_subst = emptySubst,
634 sc_how_bound = emptyVarEnv,
635 sc_vals = emptyVarEnv,
636 sc_annotations = anns }
638 data HowBound = RecFun -- These are the recursive functions for which
639 -- we seek interesting call patterns
641 | RecArg -- These are those functions' arguments, or their sub-components;
642 -- we gather occurrence information for these
644 instance Outputable HowBound where
645 ppr RecFun = text "RecFun"
646 ppr RecArg = text "RecArg"
648 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
649 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
651 scSubstId :: ScEnv -> Id -> CoreExpr
652 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
654 scSubstTy :: ScEnv -> Type -> Type
655 scSubstTy env ty = substTy (sc_subst env) ty
657 zapScSubst :: ScEnv -> ScEnv
658 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
660 extendScInScope :: ScEnv -> [Var] -> ScEnv
661 -- Bring the quantified variables into scope
662 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
664 -- Extend the substitution
665 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
666 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
668 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
669 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
671 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
672 extendHowBound env bndrs how_bound
673 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
674 [(bndr,how_bound) | bndr <- bndrs] }
676 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
677 extendBndrsWith how_bound env bndrs
678 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
680 (subst', bndrs') = substBndrs (sc_subst env) bndrs
681 hb_env' = sc_how_bound env `extendVarEnvList`
682 [(bndr,how_bound) | bndr <- bndrs']
684 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
685 extendBndrWith how_bound env bndr
686 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
688 (subst', bndr') = substBndr (sc_subst env) bndr
689 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
691 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
692 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
694 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
696 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
697 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
699 (subst', bndr') = substBndr (sc_subst env) bndr
701 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
702 extendValEnv env _ Nothing = env
703 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
705 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
709 -- we want to bind b, to (C x y)
710 -- NB1: Extends only the sc_vals part of the envt
711 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
712 -- they are potentially made alive by the [b -> C x y] binding
713 extendCaseBndrs env case_bndr con alt_bndrs
714 | isDeadBinder case_bndr
717 = (env1, map zap alt_bndrs)
718 -- NB: We used to bind v too, if scrut = (Var v); but
719 -- the simplifer has already done this so it seems
720 -- redundant to do so here
722 -- Var v -> extendValEnv env1 v cval
725 zap v | isTyCoVar v = v -- See NB2 above
726 | otherwise = zapIdOccInfo v
727 env1 = extendValEnv env case_bndr cval
730 LitAlt {} -> Just (ConVal con [])
731 DataAlt {} -> Just (ConVal con vanilla_args)
733 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
734 varsToCoreExprs alt_bndrs
737 decreaseSpecCount :: ScEnv -> Int -> ScEnv
738 -- See Note [Avoiding exponential blowup]
739 decreaseSpecCount env n_specs
740 = env { sc_count = case sc_count env of
742 Just n -> Just (n `div` (n_specs + 1)) }
743 -- The "+1" takes account of the original function;
744 -- See Note [Avoiding exponential blowup]
746 ---------------------------------------------------
747 -- See Note [SpecConstrAnnotation]
748 ignoreType :: ScEnv -> Type -> Bool
749 ignoreAltCon :: ScEnv -> AltCon -> Bool
750 forceSpecBndr :: ScEnv -> Var -> Bool
752 ignoreType _ _ = False
753 ignoreAltCon _ _ = False
754 forceSpecBndr _ _ = False
758 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
759 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
760 ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal
763 = case splitTyConApp_maybe ty of
764 Just (tycon, _) -> ignoreTyCon env tycon
767 ignoreTyCon :: ScEnv -> TyCon -> Bool
768 ignoreTyCon env tycon
769 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
771 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
773 forceSpecFunTy :: ScEnv -> Type -> Bool
774 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
776 forceSpecArgTy :: ScEnv -> Type -> Bool
777 forceSpecArgTy env ty
778 | Just ty' <- coreView ty = forceSpecArgTy env ty'
780 forceSpecArgTy env ty
781 | Just (tycon, tys) <- splitTyConApp_maybe ty
783 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
784 || any (forceSpecArgTy env) tys
786 forceSpecArgTy _ _ = False
790 Note [Avoiding exponential blowup]
791 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
792 The sc_count field of the ScEnv says how many times we are prepared to
793 duplicate a single function. But we must take care with recursive
794 specialiations. Consider
796 let $j1 = let $j2 = let $j3 = ...
804 If we specialise $j1 then in each specialisation (as well as the original)
805 we can specialise $j2, and similarly $j3. Even if we make just *one*
806 specialisation of each, becuase we also have the original we'll get 2^n
807 copies of $j3, which is not good.
809 So when recursively specialising we divide the sc_count by the number of
810 copies we are making at this level, including the original.
813 %************************************************************************
815 \subsection{Usage information: flows upwards}
817 %************************************************************************
822 scu_calls :: CallEnv, -- Calls
823 -- The functions are a subset of the
824 -- RecFuns in the ScEnv
826 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
827 } -- The domain is OutIds
829 type CallEnv = IdEnv [Call]
830 type Call = (ValueEnv, [CoreArg])
831 -- The arguments of the call, together with the
832 -- env giving the constructor bindings at the call site
835 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
837 combineCalls :: CallEnv -> CallEnv -> CallEnv
838 combineCalls = plusVarEnv_C (++)
840 combineUsage :: ScUsage -> ScUsage -> ScUsage
841 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
842 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
844 combineUsages :: [ScUsage] -> ScUsage
845 combineUsages [] = nullUsage
846 combineUsages us = foldr1 combineUsage us
848 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
849 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
850 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
851 lookupVarEnv sc_occs bndr `orElse` NoOcc)
853 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
854 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
855 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
856 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
858 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
859 | UnkOcc -- Used in some unknown way
861 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
863 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
867 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
868 is *only* taken apart or applied.
870 Functions, literal: ScrutOcc emptyUFM
871 Data constructors: ScrutOcc subs,
873 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
874 The domain of the UniqFM is the Unique of the data constructor
876 The [ArgOcc] is the occurrences of the *pattern-bound* components
877 of the data structure. E.g.
878 data T a = forall b. MkT a b (b->a)
879 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
883 instance Outputable ArgOcc where
884 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
885 ppr UnkOcc = ptext (sLit "unk-occ")
886 ppr BothOcc = ptext (sLit "both-occ")
887 ppr NoOcc = ptext (sLit "no-occ")
889 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
890 -- that if the thing is scrutinised anywhere then we get to see that
891 -- in the overall result, even if it's also used in a boxed way
892 -- This might be too agressive; see Note [Reboxing] Alternative 3
893 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
894 combineOcc NoOcc occ = occ
895 combineOcc occ NoOcc = occ
896 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
897 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
898 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
899 combineOcc UnkOcc UnkOcc = UnkOcc
900 combineOcc _ _ = BothOcc
902 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
903 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
905 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
906 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
907 -- is a variable, and an interesting variable
908 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
909 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
910 setScrutOcc env usg (Var v) occ
911 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
913 setScrutOcc _env usg _other _occ -- Catch-all
916 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
917 -- Find usage of components of data con; returns [UnkOcc...] if unknown
918 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
920 conArgOccs (ScrutOcc fm) (DataAlt dc)
921 | Just pat_arg_occs <- lookupUFM fm dc
922 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
924 conArgOccs _other _con = repeat UnkOcc
927 %************************************************************************
929 \subsection{The main recursive function}
931 %************************************************************************
933 The main recursive function gathers up usage information, and
934 creates specialised versions of functions.
937 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
938 -- The unique supply is needed when we invent
939 -- a new name for the specialised function and its args
941 scExpr env e = scExpr' env e
944 scExpr' env (Var v) = case scSubstId env v of
945 Var v' -> return (varUsage env v' UnkOcc, Var v')
946 e' -> scExpr (zapScSubst env) e'
948 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
949 scExpr' _ e@(Lit {}) = return (nullUsage, e)
950 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
951 return (usg, Note n e')
952 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
953 return (usg, Cast e' (scSubstTy env co))
954 scExpr' env e@(App _ _) = scApp env (collectArgs e)
955 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
956 (usg, e') <- scExpr env' e
957 return (usg, Lam b' e')
959 scExpr' env (Case scrut b ty alts)
960 = do { (scrut_usg, scrut') <- scExpr env scrut
961 ; case isValue (sc_vals env) scrut' of
962 Just (ConVal con args) -> sc_con_app con args scrut'
963 _other -> sc_vanilla scrut_usg scrut'
966 sc_con_app con args scrut' -- Known constructor; simplify
967 = do { let (_, bs, rhs) = findAlt con alts
968 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
969 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
970 ; scExpr alt_env' rhs }
972 sc_vanilla scrut_usg scrut' -- Normal case
973 = do { let (alt_env,b') = extendBndrWith RecArg env b
974 -- Record RecArg for the components
976 ; (alt_usgs, alt_occs, alts')
977 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
979 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
980 scrut_occ = foldr combineOcc b_occ alt_occs
981 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
982 -- The combined usage of the scrutinee is given
983 -- by scrut_occ, which is passed to scScrut, which
984 -- in turn treats a bare-variable scrutinee specially
986 ; return (alt_usg `combineUsage` scrut_usg',
987 Case scrut' b' (scSubstTy env ty) alts') }
989 sc_alt env _scrut' b' (con,bs,rhs)
990 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
991 (env2, bs2) = extendCaseBndrs env1 b' con bs1
992 ; (usg,rhs') <- scExpr env2 rhs
993 ; let (usg', arg_occs) = lookupOccs usg bs2
994 scrut_occ = case con of
995 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
996 _ -> ScrutOcc emptyUFM
997 ; return (usg', scrut_occ, (con, bs2, rhs')) }
999 scExpr' env (Let (NonRec bndr rhs) body)
1000 | isTyCoVar bndr -- Type-lets may be created by doBeta
1001 = scExpr' (extendScSubst env bndr rhs) body
1004 = do { let (body_env, bndr') = extendBndr env bndr
1005 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
1007 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
1008 -- Note [Local let bindings]
1009 RI _ rhs' _ _ _ = rhs_info
1010 body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
1012 ; (body_usg, body') <- scExpr body_env3 body
1014 -- NB: We don't use the ForceSpecConstr mechanism (see
1015 -- Note [Forcing specialisation]) for non-recursive bindings
1016 -- at the moment. I'm not sure if this is the right thing to do.
1017 ; let force_spec = False
1018 ; (spec_usg, specs) <- specialise env force_spec
1019 (scu_calls body_usg)
1021 (SI [] 0 (Just rhs_usg))
1023 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1024 `combineUsage` spec_usg,
1025 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1029 -- A *local* recursive group: see Note [Local recursive groups]
1030 scExpr' env (Let (Rec prs) body)
1031 = do { let (bndrs,rhss) = unzip prs
1032 (rhs_env1,bndrs') = extendRecBndrs env bndrs
1033 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1034 force_spec = any (forceSpecBndr env) bndrs'
1035 -- Note [Forcing specialisation]
1037 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1038 ; (body_usg, body') <- scExpr rhs_env2 body
1040 -- NB: start specLoop from body_usg
1041 ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
1042 (scu_calls body_usg) rhs_infos nullUsage
1043 [SI [] 0 (Just usg) | usg <- rhs_usgs]
1044 -- Do not unconditionally use rhs_usgs.
1045 -- Instead use them only if we find an unspecialised call
1046 -- See Note [Local recursive groups]
1048 ; let all_usg = spec_usg `combineUsage` body_usg
1049 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1051 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1055 Note [Local let bindings]
1056 ~~~~~~~~~~~~~~~~~~~~~~~~~
1057 It is not uncommon to find this
1059 let $j = \x. <blah> in ...$j True...$j True...
1061 Here $j is an arbitrary let-bound function, but it often comes up for
1062 join points. We might like to specialise $j for its call patterns.
1063 Notice the difference from a letrec, where we look for call patterns
1064 in the *RHS* of the function. Here we look for call patterns in the
1067 At one point I predicated this on the RHS mentioning the outer
1068 recursive function, but that's not essential and might even be
1069 harmful. I'm not sure.
1073 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1075 scApp env (Var fn, args) -- Function is a variable
1076 = ASSERT( not (null args) )
1077 do { args_w_usgs <- mapM (scExpr env) args
1078 ; let (arg_usgs, args') = unzip args_w_usgs
1079 arg_usg = combineUsages arg_usgs
1080 ; case scSubstId env fn of
1081 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1082 -- Do beta-reduction and try again
1084 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1086 fn_usg = case lookupHowBound env fn' of
1087 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
1088 scu_occs = emptyVarEnv }
1089 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1090 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
1091 Nothing -> nullUsage
1094 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1095 -- NB: doing this ignores any usage info from the substituted
1096 -- function, but I don't think that matters. If it does
1099 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1100 -- ToDo: adjust for System IF
1101 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1102 doBeta fn args = mkApps fn args
1104 -- The function is almost always a variable, but not always.
1105 -- In particular, if this pass follows float-in,
1106 -- which it may, we can get
1107 -- (let f = ...f... in f) arg1 arg2
1108 scApp env (other_fn, args)
1109 = do { (fn_usg, fn') <- scExpr env other_fn
1110 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1111 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1113 ----------------------
1114 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1115 scTopBind env (Rec prs)
1116 | Just threshold <- sc_size env
1118 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1119 -- No specialisation
1120 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1121 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1122 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1123 | otherwise -- Do specialisation
1124 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1125 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1127 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1128 ; let rhs_usg = combineUsages rhs_usgs
1130 ; (_, specs) <- specLoop rhs_env2 force_spec
1131 (scu_calls rhs_usg) rhs_infos nullUsage
1132 [SI [] 0 Nothing | _ <- bndrs]
1134 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1135 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1137 (bndrs,rhss) = unzip prs
1138 force_spec = any (forceSpecBndr env) bndrs
1139 -- Note [Forcing specialisation]
1141 scTopBind env (NonRec bndr rhs)
1142 = do { (_, rhs') <- scExpr env rhs
1143 ; let (env1, bndr') = extendBndr env bndr
1144 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1145 ; return (env2, NonRec bndr' rhs') }
1147 ----------------------
1148 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1149 scRecRhs env (bndr,rhs)
1150 = do { let (arg_bndrs,body) = collectBinders rhs
1151 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1152 ; (body_usg, body') <- scExpr body_env body
1153 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1154 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1155 arg_bndrs body arg_occs) }
1156 -- The arg_occs says how the visible,
1157 -- lambda-bound binders of the RHS are used
1158 -- (including the TyVar binders)
1159 -- Two pats are the same if they match both ways
1161 ----------------------
1162 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1163 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1164 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1165 [(fn `addIdSpecialisations` rules, new_rhs)]
1167 rules = [r | OS _ r _ _ <- specs]
1169 ----------------------
1170 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1172 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1173 , scu_occs = unitVarEnv v use }
1174 | otherwise = nullUsage
1178 %************************************************************************
1180 The specialiser itself
1182 %************************************************************************
1185 data RhsInfo = RI OutId -- The binder
1186 OutExpr -- The new RHS
1187 [InVar] InExpr -- The *original* RHS (\xs.body)
1188 -- Note [Specialise original body]
1189 [ArgOcc] -- Info on how the xs occur in body
1191 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1193 Int -- Length of specs; used for numbering them
1195 (Maybe ScUsage) -- Nothing => we have generated specialisations
1196 -- from calls in the *original* RHS
1197 -- Just cs => we haven't, and this is the usage
1198 -- of the original RHS
1199 -- See Note [Local recursive groups]
1201 -- One specialisation: Rule plus definition
1202 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1203 CoreRule -- Rule connecting original id with the specialisation
1204 OutId OutExpr -- Spec id + its rhs
1208 -> Bool -- force specialisation?
1209 -- Note [Forcing specialisation]
1212 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1213 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1214 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1215 = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1216 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1217 new_usg = combineUsages new_usg_s
1218 new_calls = scu_calls new_usg
1219 all_usg = usg_so_far `combineUsage` new_usg
1220 ; if isEmptyVarEnv new_calls then
1221 return (all_usg, all_specs)
1223 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1227 -> Bool -- force specialisation?
1228 -- Note [Forcing specialisation]
1229 -> CallEnv -- Info on calls
1231 -> SpecInfo -- Original RHS plus patterns dealt with
1232 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1234 -- Note: the rhs here is the optimised version of the original rhs
1235 -- So when we make a specialised copy of the RHS, we're starting
1236 -- from an RHS whose nested functions have been optimised already.
1238 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
1239 spec_info@(SI specs spec_count mb_unspec)
1240 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1241 , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1242 , notNull arg_bndrs -- Only specialise functions
1243 , Just all_calls <- lookupVarEnv bind_calls fn
1244 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1245 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1246 -- , text "arg_occs" <+> ppr arg_occs
1247 -- , text "calls" <+> ppr all_calls
1248 -- , text "good pats" <+> ppr pats]) $
1251 -- Bale out if too many specialisations
1252 ; let n_pats = length pats
1253 spec_count' = n_pats + spec_count
1254 ; case sc_count env of
1255 Just max | not force_spec && spec_count' > max
1256 -> pprTrace "SpecConstr" msg $
1257 return (nullUsage, spec_info)
1259 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1260 , nest 2 (ptext (sLit "has") <+>
1261 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1262 ptext (sLit "but the limit is") <+> int max) ]
1263 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1265 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1266 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1268 _normal_case -> do {
1270 let spec_env = decreaseSpecCount env n_pats
1271 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1272 (pats `zip` [spec_count..])
1273 -- See Note [Specialise original body]
1275 ; let spec_usg = combineUsages spec_usgs
1276 (new_usg, mb_unspec')
1278 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1279 _ -> (spec_usg, mb_unspec)
1281 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1283 = return (nullUsage, spec_info) -- The boring case
1286 ---------------------
1288 -> OutId -- Function
1289 -> [InVar] -- Lambda-binders of RHS; should match patterns
1290 -> InExpr -- Body of the original function
1292 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1294 -- spec_one creates a specialised copy of the function, together
1295 -- with a rule for using it. I'm very proud of how short this
1296 -- function is, considering what it does :-).
1302 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1303 [c::*, v::(b,c) are presumably bound by the (...) part]
1305 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1306 (...entire body of f...) [b -> (b,c),
1307 y -> ((:) (a,(b,c)) (x,v) hw)]
1309 RULE: forall b::* c::*, -- Note, *not* forall a, x
1313 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1316 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1317 = do { spec_uniq <- getUniqueUs
1318 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1319 (arg_bndrs `zip` pats)
1321 fn_loc = nameSrcSpan fn_name
1322 spec_occ = mkSpecOcc (nameOccName fn_name)
1323 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1324 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1325 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1328 -- Specialise the body
1329 ; (spec_usg, spec_body) <- scExpr spec_env body
1331 -- ; pprTrace "done spec_one}" (ppr fn) $
1334 -- And build the results
1335 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1336 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1337 `setIdArity` count isId spec_lam_args
1338 spec_str = calcSpecStrictness fn spec_lam_args pats
1339 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1340 -- Usual w/w hack to avoid generating
1341 -- a spec_rhs of unlifted type and no args
1343 spec_rhs = mkLams spec_lam_args spec_body
1344 body_ty = exprType spec_body
1345 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1346 inline_act = idInlineActivation fn
1347 rule = mkRule True {- Auto -} True {- Local -}
1348 rule_name inline_act fn_name qvars pats rule_rhs
1349 -- See Note [Transfer activation]
1350 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1352 calcSpecStrictness :: Id -- The original function
1353 -> [Var] -> [CoreExpr] -- Call pattern
1354 -> StrictSig -- Strictness of specialised thing
1355 -- See Note [Transfer strictness]
1356 calcSpecStrictness fn qvars pats
1357 = StrictSig (mkTopDmdType spec_dmds TopRes)
1359 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1360 StrictSig (DmdType _ dmds _) = idStrictness fn
1362 dmd_env = go emptyVarEnv dmds pats
1364 go env ds (Type {} : pats) = go env ds pats
1365 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1368 go_one env d (Var v) = extendVarEnv_C both env v d
1369 go_one env (Box d) e = go_one env d e
1370 go_one env (Eval (Prod ds)) e
1371 | (Var _, args) <- collectArgs e = go env ds args
1372 go_one env _ _ = env
1376 Note [Specialise original body]
1377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1378 The RhsInfo for a binding keeps the *original* body of the binding. We
1379 must specialise that, *not* the result of applying specExpr to the RHS
1380 (which is also kept in RhsInfo). Otherwise we end up specialising a
1381 specialised RHS, and that can lead directly to exponential behaviour.
1383 Note [Transfer activation]
1384 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1385 This note is for SpecConstr, but exactly the same thing
1386 happens in the overloading specialiser; see
1387 Note [Auto-specialisation and RULES] in Specialise.
1389 In which phase should the specialise-constructor rules be active?
1390 Originally I made them always-active, but Manuel found that this
1391 defeated some clever user-written rules. Then I made them active only
1392 in Phase 0; after all, currently, the specConstr transformation is
1393 only run after the simplifier has reached Phase 0, but that meant
1394 that specialisations didn't fire inside wrappers; see test
1395 simplCore/should_compile/spec-inline.
1397 So now I just use the inline-activation of the parent Id, as the
1398 activation for the specialiation RULE, just like the main specialiser;
1400 This in turn means there is no point in specialising NOINLINE things,
1401 so we test for that.
1403 Note [Transfer strictness]
1404 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1405 We must transfer strictness information from the original function to
1406 the specialised one. Suppose, for example
1409 and a RULE f (a:as) b = f_spec a as b
1411 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1412 when calling f_spec instead of call-by-value. And that can result in
1413 unbounded worsening in space (cf the classic foldl vs foldl')
1415 See Trac #3437 for a good example.
1417 The function calcSpecStrictness performs the calculation.
1420 %************************************************************************
1422 \subsection{Argument analysis}
1424 %************************************************************************
1426 This code deals with analysing call-site arguments to see whether
1427 they are constructor applications.
1431 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1434 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1435 -- Result has no duplicate patterns,
1436 -- nor ones mentioned in done_pats
1437 -- Bool indicates that there was at least one boring pattern
1438 callsToPats env done_specs bndr_occs calls
1439 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1441 ; let good_pats :: [([Var], [CoreArg])]
1442 good_pats = catMaybes mb_pats
1443 done_pats = [p | OS p _ _ _ <- done_specs]
1444 is_done p = any (samePat p) done_pats
1446 ; return (any isNothing mb_pats,
1447 filterOut is_done (nubBy samePat good_pats)) }
1449 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1450 -- The [Var] is the variables to quantify over in the rule
1451 -- Type variables come first, since they may scope
1452 -- over the following term variables
1453 -- The [CoreExpr] are the argument patterns for the rule
1454 callToPats env bndr_occs (con_env, args)
1455 | length args < length bndr_occs -- Check saturated
1458 = do { let in_scope = substInScope (sc_subst env)
1459 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1460 ; let (interesting_s, pats) = unzip prs
1461 pat_fvs = varSetElems (exprsFreeVars pats)
1462 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1463 -- Quantify over variables that are not in sccpe
1465 -- See Note [Shadowing] at the top
1467 (tvs, ids) = partition isTyCoVar qvars
1469 -- Put the type variables first; the type of a term
1470 -- variable may mention a type variable
1472 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1474 then return (Just (qvars', pats))
1475 else return Nothing }
1477 -- argToPat takes an actual argument, and returns an abstracted
1478 -- version, consisting of just the "constructor skeleton" of the
1479 -- argument, with non-constructor sub-expression replaced by new
1480 -- placeholder variables. For example:
1481 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1484 -> InScopeSet -- What's in scope at the fn defn site
1485 -> ValueEnv -- ValueEnv at the call site
1486 -> CoreArg -- A call arg (or component thereof)
1488 -> UniqSM (Bool, CoreArg)
1489 -- Returns (interesting, pat),
1490 -- where pat is the pattern derived from the argument
1491 -- intersting=True if the pattern is non-trivial (not a variable or type)
1492 -- E.g. x:xs --> (True, x:xs)
1493 -- f xs --> (False, w) where w is a fresh wildcard
1494 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1495 -- \x. x+y --> (True, \x. x+y)
1496 -- lvl7 --> (True, lvl7) if lvl7 is bound
1497 -- somewhere further out
1499 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1500 = return (False, arg)
1502 argToPat env in_scope val_env (Note _ arg) arg_occ
1503 = argToPat env in_scope val_env arg arg_occ
1504 -- Note [Notes in call patterns]
1505 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1506 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1507 -- Perhaps we should not ignore profiling notes, but I'm going to
1508 -- ride roughshod over them all for now.
1509 --- See Note [Notes in RULE matching] in Rules
1511 argToPat env in_scope val_env (Let _ arg) arg_occ
1512 = argToPat env in_scope val_env arg arg_occ
1513 -- See Note [Matching lets] in Rule.lhs
1514 -- Look through let expressions
1515 -- e.g. f (let v = rhs in (v,w))
1516 -- Here we can specialise for f (v,w)
1517 -- because the rule-matcher will look through the let.
1519 {- Disabled; see Note [Matching cases] in Rule.lhs
1520 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1521 | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
1522 = argToPat env in_scope val_env rhs arg_occ
1525 argToPat env in_scope val_env (Cast arg co) arg_occ
1526 | not (ignoreType env ty2)
1527 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1528 ; if not interesting then
1531 { -- Make a wild-card pattern for the coercion
1533 ; let co_name = mkSysTvName uniq (fsLit "sg")
1534 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1535 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1537 (ty1, ty2) = coercionKind co
1541 {- Disabling lambda specialisation for now
1542 It's fragile, and the spec_loop can be infinite
1543 argToPat in_scope val_env arg arg_occ
1545 = return (True, arg)
1547 is_value_lam (Lam v e) -- Spot a value lambda, even if
1548 | isId v = True -- it is inside a type lambda
1549 | otherwise = is_value_lam e
1550 is_value_lam other = False
1553 -- Check for a constructor application
1554 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1555 argToPat env in_scope val_env arg arg_occ
1556 | Just (ConVal dc args) <- isValue val_env arg
1557 , not (ignoreAltCon env dc)
1559 ScrutOcc _ -> True -- Used only by case scrutinee
1560 BothOcc -> case arg of -- Used elsewhere
1561 App {} -> True -- see Note [Reboxing]
1563 _other -> False -- No point; the arg is not decomposed
1564 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1565 ; return (True, mk_con_app dc (map snd args')) }
1567 -- Check if the argument is a variable that
1568 -- is in scope at the function definition site
1569 -- It's worth specialising on this if
1570 -- (a) it's used in an interesting way in the body
1571 -- (b) we know what its value is
1572 argToPat env in_scope val_env (Var v) arg_occ
1573 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1575 not (ignoreType env (varType v))
1576 = return (True, Var v)
1579 | isLocalId v = v `elemInScopeSet` in_scope
1580 && isJust (lookupVarEnv val_env v)
1581 -- Local variables have values in val_env
1582 | otherwise = isValueUnfolding (idUnfolding v)
1583 -- Imports have unfoldings
1585 -- I'm really not sure what this comment means
1586 -- And by not wild-carding we tend to get forall'd
1587 -- variables that are in soope, which in turn can
1588 -- expose the weakness in let-matching
1589 -- See Note [Matching lets] in Rules
1591 -- Check for a variable bound inside the function.
1592 -- Don't make a wild-card, because we may usefully share
1593 -- e.g. f a = let x = ... in f (x,x)
1594 -- NB: this case follows the lambda and con-app cases!!
1595 -- argToPat _in_scope _val_env (Var v) _arg_occ
1596 -- = return (False, Var v)
1597 -- SLPJ : disabling this to avoid proliferation of versions
1598 -- also works badly when thinking about seeding the loop
1599 -- from the body of the let
1600 -- f x y = letrec g z = ... in g (x,y)
1601 -- We don't want to specialise for that *particular* x,y
1603 -- The default case: make a wild-card
1604 argToPat _env _in_scope _val_env arg _arg_occ
1605 = wildCardPat (exprType arg)
1607 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1608 wildCardPat ty = do { uniq <- getUniqueUs
1609 ; let id = mkSysLocal (fsLit "sc") uniq ty
1610 ; return (False, Var id) }
1612 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1613 -> [(CoreArg, ArgOcc)]
1614 -> UniqSM [(Bool, CoreArg)]
1615 argsToPats env in_scope val_env args
1618 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1623 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1624 isValue _env (Lit lit)
1625 = Just (ConVal (LitAlt lit) [])
1628 | Just stuff <- lookupVarEnv env v
1629 = Just stuff -- You might think we could look in the idUnfolding here
1630 -- but that doesn't take account of which branch of a
1631 -- case we are in, which is the whole point
1633 | not (isLocalId v) && isCheapUnfolding unf
1634 = isValue env (unfoldingTemplate unf)
1637 -- However we do want to consult the unfolding
1638 -- as well, for let-bound constructors!
1640 isValue env (Lam b e)
1641 | isTyCoVar b = case isValue env e of
1642 Just _ -> Just LambdaVal
1644 | otherwise = Just LambdaVal
1646 isValue _env expr -- Maybe it's a constructor application
1647 | (Var fun, args) <- collectArgs expr
1648 = case isDataConWorkId_maybe fun of
1650 Just con | args `lengthAtLeast` dataConRepArity con
1651 -- Check saturated; might be > because the
1652 -- arity excludes type args
1653 -> Just (ConVal (DataAlt con) args)
1655 _other | valArgCount args < idArity fun
1656 -- Under-applied function
1657 -> Just LambdaVal -- Partial application
1661 isValue _env _expr = Nothing
1663 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1664 mk_con_app (LitAlt lit) [] = Lit lit
1665 mk_con_app (DataAlt con) args = mkConApp con args
1666 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1668 samePat :: CallPat -> CallPat -> Bool
1669 samePat (vs1, as1) (vs2, as2)
1672 same (Var v1) (Var v2)
1673 | v1 `elem` vs1 = v2 `elem` vs2
1674 | v2 `elem` vs2 = False
1675 | otherwise = v1 == v2
1677 same (Lit l1) (Lit l2) = l1==l2
1678 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1680 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1681 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1682 same (Cast e1 _) e2 = same e1 e2
1683 same e1 (Note _ e2) = same e1 e2
1684 same e1 (Cast e2 _) = same e1 e2
1686 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1687 False -- Let, lambda, case should not occur
1688 bad (Case {}) = True
1694 Note [Ignore type differences]
1695 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1696 We do not want to generate specialisations where the call patterns
1697 differ only in their type arguments! Not only is it utterly useless,
1698 but it also means that (with polymorphic recursion) we can generate
1699 an infinite number of specialisations. Example is Data.Sequence.adjustTree,