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 -----------------------------------------------------
461 Stuff not yet handled
462 -----------------------------------------------------
464 Here are notes arising from Roman's work that I don't want to lose.
470 foo :: Int -> T Int -> Int
472 foo x t | even x = case t of { T n -> foo (x-n) t }
473 | otherwise = foo (x-1) t
475 SpecConstr does no specialisation, because the second recursive call
476 looks like a boxed use of the argument. A pity.
478 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
480 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
481 case ww_sFo of ds_Xw6 [Just L] {
483 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
484 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
486 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
487 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
488 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
494 data a :*: b = !a :*: !b
497 foo :: (Int :*: T Int) -> Int
499 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
500 | otherwise = foo ((x-1) :*: t)
502 Very similar to the previous one, except that the parameters are now in
503 a strict tuple. Before SpecConstr, we have
505 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
507 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
509 case ww_sFU of ds_Xws [Just L] {
511 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
513 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
514 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
517 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
518 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
519 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
523 We get two specialisations:
524 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
525 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
526 = Foo.$s$wfoo1 a_sFB sc_sGC ;
527 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
528 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
529 = Foo.$s$wfoo y_aFp sc_sGC ;
531 But perhaps the first one isn't good. After all, we know that tpl_B2 is
532 a T (I# x) really, because T is strict and Int has one constructor. (We can't
533 unbox the strict fields, becuase T is polymorphic!)
535 %************************************************************************
537 \subsection{Top level wrapper stuff}
539 %************************************************************************
542 specConstrProgram :: ModGuts -> CoreM ModGuts
543 specConstrProgram guts
545 dflags <- getDynFlags
546 us <- getUniqueSupplyM
547 annos <- getFirstAnnotations deserializeWithData guts
548 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
549 return (guts { mg_binds = binds' })
552 go env (bind:binds) = do (env', bind') <- scTopBind env bind
553 binds' <- go env' binds
554 return (bind' : binds')
558 %************************************************************************
560 \subsection{Environment: goes downwards}
562 %************************************************************************
565 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
566 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
567 -- See Note [Avoiding exponential blowup]
569 sc_subst :: Subst, -- Current substitution
570 -- Maps InIds to OutExprs
572 sc_how_bound :: HowBoundEnv,
573 -- Binds interesting non-top-level variables
574 -- Domain is OutVars (*after* applying the substitution)
577 -- Domain is OutIds (*after* applying the substitution)
578 -- Used even for top-level bindings (but not imported ones)
580 sc_annotations :: UniqFM SpecConstrAnnotation
583 ---------------------
584 -- As we go, we apply a substitution (sc_subst) to the current term
585 type InExpr = CoreExpr -- _Before_ applying the subst
588 type OutExpr = CoreExpr -- _After_ applying the subst
592 ---------------------
593 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
595 ---------------------
596 type ValueEnv = IdEnv Value -- Domain is OutIds
597 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
598 -- The AltCon is never DEFAULT
599 | LambdaVal -- Inlinable lambdas or PAPs
601 instance Outputable Value where
602 ppr (ConVal con args) = ppr con <+> interpp'SP args
603 ppr LambdaVal = ptext (sLit "<Lambda>")
605 ---------------------
606 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
607 initScEnv dflags anns
608 = SCE { sc_size = specConstrThreshold dflags,
609 sc_count = specConstrCount dflags,
610 sc_subst = emptySubst,
611 sc_how_bound = emptyVarEnv,
612 sc_vals = emptyVarEnv,
613 sc_annotations = anns }
615 data HowBound = RecFun -- These are the recursive functions for which
616 -- we seek interesting call patterns
618 | RecArg -- These are those functions' arguments, or their sub-components;
619 -- we gather occurrence information for these
621 instance Outputable HowBound where
622 ppr RecFun = text "RecFun"
623 ppr RecArg = text "RecArg"
625 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
626 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
628 scSubstId :: ScEnv -> Id -> CoreExpr
629 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
631 scSubstTy :: ScEnv -> Type -> Type
632 scSubstTy env ty = substTy (sc_subst env) ty
634 zapScSubst :: ScEnv -> ScEnv
635 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
637 extendScInScope :: ScEnv -> [Var] -> ScEnv
638 -- Bring the quantified variables into scope
639 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
641 -- Extend the substitution
642 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
643 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
645 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
646 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
648 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
649 extendHowBound env bndrs how_bound
650 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
651 [(bndr,how_bound) | bndr <- bndrs] }
653 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
654 extendBndrsWith how_bound env bndrs
655 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
657 (subst', bndrs') = substBndrs (sc_subst env) bndrs
658 hb_env' = sc_how_bound env `extendVarEnvList`
659 [(bndr,how_bound) | bndr <- bndrs']
661 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
662 extendBndrWith how_bound env bndr
663 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
665 (subst', bndr') = substBndr (sc_subst env) bndr
666 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
668 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
669 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
671 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
673 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
674 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
676 (subst', bndr') = substBndr (sc_subst env) bndr
678 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
679 extendValEnv env _ Nothing = env
680 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
682 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
686 -- we want to bind b, to (C x y)
687 -- NB1: Extends only the sc_vals part of the envt
688 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
689 -- they are potentially made alive by the [b -> C x y] binding
690 extendCaseBndrs env case_bndr con alt_bndrs
691 | isDeadBinder case_bndr
694 = (env1, map zap alt_bndrs)
695 -- NB: We used to bind v too, if scrut = (Var v); but
696 -- the simplifer has already done this so it seems
697 -- redundant to do so here
699 -- Var v -> extendValEnv env1 v cval
702 zap v | isTyCoVar v = v -- See NB2 above
703 | otherwise = zapIdOccInfo v
704 env1 = extendValEnv env case_bndr cval
707 LitAlt {} -> Just (ConVal con [])
708 DataAlt {} -> Just (ConVal con vanilla_args)
710 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
711 varsToCoreExprs alt_bndrs
714 decreaseSpecCount :: ScEnv -> Int -> ScEnv
715 -- See Note [Avoiding exponential blowup]
716 decreaseSpecCount env n_specs
717 = env { sc_count = case sc_count env of
719 Just n -> Just (n `div` (n_specs + 1)) }
720 -- The "+1" takes account of the original function;
721 -- See Note [Avoiding exponential blowup]
723 ---------------------------------------------------
724 -- See Note [SpecConstrAnnotation]
725 ignoreType :: ScEnv -> Type -> Bool
726 ignoreAltCon :: ScEnv -> AltCon -> Bool
727 forceSpecBndr :: ScEnv -> Var -> Bool
729 ignoreType _ _ = False
730 ignoreAltCon _ _ = False
731 forceSpecBndr _ _ = False
735 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
736 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
737 ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal
740 = case splitTyConApp_maybe ty of
741 Just (tycon, _) -> ignoreTyCon env tycon
744 ignoreTyCon :: ScEnv -> TyCon -> Bool
745 ignoreTyCon env tycon
746 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
748 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
750 forceSpecFunTy :: ScEnv -> Type -> Bool
751 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
753 forceSpecArgTy :: ScEnv -> Type -> Bool
754 forceSpecArgTy env ty
755 | Just ty' <- coreView ty = forceSpecArgTy env ty'
757 forceSpecArgTy env ty
758 | Just (tycon, tys) <- splitTyConApp_maybe ty
760 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
761 || any (forceSpecArgTy env) tys
763 forceSpecArgTy _ _ = False
767 Note [Avoiding exponential blowup]
768 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
769 The sc_count field of the ScEnv says how many times we are prepared to
770 duplicate a single function. But we must take care with recursive
771 specialiations. Consider
773 let $j1 = let $j2 = let $j3 = ...
781 If we specialise $j1 then in each specialisation (as well as the original)
782 we can specialise $j2, and similarly $j3. Even if we make just *one*
783 specialisation of each, becuase we also have the original we'll get 2^n
784 copies of $j3, which is not good.
786 So when recursively specialising we divide the sc_count by the number of
787 copies we are making at this level, including the original.
790 %************************************************************************
792 \subsection{Usage information: flows upwards}
794 %************************************************************************
799 scu_calls :: CallEnv, -- Calls
800 -- The functions are a subset of the
801 -- RecFuns in the ScEnv
803 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
804 } -- The domain is OutIds
806 type CallEnv = IdEnv [Call]
807 type Call = (ValueEnv, [CoreArg])
808 -- The arguments of the call, together with the
809 -- env giving the constructor bindings at the call site
812 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
814 combineCalls :: CallEnv -> CallEnv -> CallEnv
815 combineCalls = plusVarEnv_C (++)
817 combineUsage :: ScUsage -> ScUsage -> ScUsage
818 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
819 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
821 combineUsages :: [ScUsage] -> ScUsage
822 combineUsages [] = nullUsage
823 combineUsages us = foldr1 combineUsage us
825 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
826 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
827 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
828 lookupVarEnv sc_occs bndr `orElse` NoOcc)
830 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
831 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
832 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
833 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
835 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
836 | UnkOcc -- Used in some unknown way
838 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
840 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
844 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
845 is *only* taken apart or applied.
847 Functions, literal: ScrutOcc emptyUFM
848 Data constructors: ScrutOcc subs,
850 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
851 The domain of the UniqFM is the Unique of the data constructor
853 The [ArgOcc] is the occurrences of the *pattern-bound* components
854 of the data structure. E.g.
855 data T a = forall b. MkT a b (b->a)
856 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
860 instance Outputable ArgOcc where
861 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
862 ppr UnkOcc = ptext (sLit "unk-occ")
863 ppr BothOcc = ptext (sLit "both-occ")
864 ppr NoOcc = ptext (sLit "no-occ")
866 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
867 -- that if the thing is scrutinised anywhere then we get to see that
868 -- in the overall result, even if it's also used in a boxed way
869 -- This might be too agressive; see Note [Reboxing] Alternative 3
870 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
871 combineOcc NoOcc occ = occ
872 combineOcc occ NoOcc = occ
873 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
874 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
875 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
876 combineOcc UnkOcc UnkOcc = UnkOcc
877 combineOcc _ _ = BothOcc
879 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
880 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
882 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
883 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
884 -- is a variable, and an interesting variable
885 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
886 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
887 setScrutOcc env usg (Var v) occ
888 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
890 setScrutOcc _env usg _other _occ -- Catch-all
893 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
894 -- Find usage of components of data con; returns [UnkOcc...] if unknown
895 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
897 conArgOccs (ScrutOcc fm) (DataAlt dc)
898 | Just pat_arg_occs <- lookupUFM fm dc
899 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
901 conArgOccs _other _con = repeat UnkOcc
904 %************************************************************************
906 \subsection{The main recursive function}
908 %************************************************************************
910 The main recursive function gathers up usage information, and
911 creates specialised versions of functions.
914 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
915 -- The unique supply is needed when we invent
916 -- a new name for the specialised function and its args
918 scExpr env e = scExpr' env e
921 scExpr' env (Var v) = case scSubstId env v of
922 Var v' -> return (varUsage env v' UnkOcc, Var v')
923 e' -> scExpr (zapScSubst env) e'
925 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
926 scExpr' _ e@(Lit {}) = return (nullUsage, e)
927 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
928 return (usg, Note n e')
929 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
930 return (usg, Cast e' (scSubstTy env co))
931 scExpr' env e@(App _ _) = scApp env (collectArgs e)
932 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
933 (usg, e') <- scExpr env' e
934 return (usg, Lam b' e')
936 scExpr' env (Case scrut b ty alts)
937 = do { (scrut_usg, scrut') <- scExpr env scrut
938 ; case isValue (sc_vals env) scrut' of
939 Just (ConVal con args) -> sc_con_app con args scrut'
940 _other -> sc_vanilla scrut_usg scrut'
943 sc_con_app con args scrut' -- Known constructor; simplify
944 = do { let (_, bs, rhs) = findAlt con alts
945 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
946 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
947 ; scExpr alt_env' rhs }
949 sc_vanilla scrut_usg scrut' -- Normal case
950 = do { let (alt_env,b') = extendBndrWith RecArg env b
951 -- Record RecArg for the components
953 ; (alt_usgs, alt_occs, alts')
954 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
956 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
957 scrut_occ = foldr combineOcc b_occ alt_occs
958 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
959 -- The combined usage of the scrutinee is given
960 -- by scrut_occ, which is passed to scScrut, which
961 -- in turn treats a bare-variable scrutinee specially
963 ; return (alt_usg `combineUsage` scrut_usg',
964 Case scrut' b' (scSubstTy env ty) alts') }
966 sc_alt env _scrut' b' (con,bs,rhs)
967 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
968 (env2, bs2) = extendCaseBndrs env1 b' con bs1
969 ; (usg,rhs') <- scExpr env2 rhs
970 ; let (usg', arg_occs) = lookupOccs usg bs2
971 scrut_occ = case con of
972 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
973 _ -> ScrutOcc emptyUFM
974 ; return (usg', scrut_occ, (con, bs2, rhs')) }
976 scExpr' env (Let (NonRec bndr rhs) body)
977 | isTyCoVar bndr -- Type-lets may be created by doBeta
978 = scExpr' (extendScSubst env bndr rhs) body
981 = do { let (body_env, bndr') = extendBndr env bndr
982 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
984 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
985 -- Note [Local let bindings]
986 RI _ rhs' _ _ _ = rhs_info
987 body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
989 ; (body_usg, body') <- scExpr body_env3 body
991 -- NB: We don't use the ForceSpecConstr mechanism (see
992 -- Note [Forcing specialisation]) for non-recursive bindings
993 -- at the moment. I'm not sure if this is the right thing to do.
994 ; let force_spec = False
995 ; (spec_usg, specs) <- specialise env force_spec
998 (SI [] 0 (Just rhs_usg))
1000 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
1001 `combineUsage` spec_usg,
1002 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
1006 -- A *local* recursive group: see Note [Local recursive groups]
1007 scExpr' env (Let (Rec prs) body)
1008 = do { let (bndrs,rhss) = unzip prs
1009 (rhs_env1,bndrs') = extendRecBndrs env bndrs
1010 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1011 force_spec = any (forceSpecBndr env) bndrs'
1012 -- Note [Forcing specialisation]
1014 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1015 ; (body_usg, body') <- scExpr rhs_env2 body
1017 -- NB: start specLoop from body_usg
1018 ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
1019 (scu_calls body_usg) rhs_infos nullUsage
1020 [SI [] 0 (Just usg) | usg <- rhs_usgs]
1021 -- Do not unconditionally use rhs_usgs.
1022 -- Instead use them only if we find an unspecialised call
1023 -- See Note [Local recursive groups]
1025 ; let all_usg = spec_usg `combineUsage` body_usg
1026 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
1028 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
1032 Note [Local let bindings]
1033 ~~~~~~~~~~~~~~~~~~~~~~~~~
1034 It is not uncommon to find this
1036 let $j = \x. <blah> in ...$j True...$j True...
1038 Here $j is an arbitrary let-bound function, but it often comes up for
1039 join points. We might like to specialise $j for its call patterns.
1040 Notice the difference from a letrec, where we look for call patterns
1041 in the *RHS* of the function. Here we look for call patterns in the
1044 At one point I predicated this on the RHS mentioning the outer
1045 recursive function, but that's not essential and might even be
1046 harmful. I'm not sure.
1050 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1052 scApp env (Var fn, args) -- Function is a variable
1053 = ASSERT( not (null args) )
1054 do { args_w_usgs <- mapM (scExpr env) args
1055 ; let (arg_usgs, args') = unzip args_w_usgs
1056 arg_usg = combineUsages arg_usgs
1057 ; case scSubstId env fn of
1058 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1059 -- Do beta-reduction and try again
1061 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1063 fn_usg = case lookupHowBound env fn' of
1064 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
1065 scu_occs = emptyVarEnv }
1066 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1067 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
1068 Nothing -> nullUsage
1071 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1072 -- NB: doing this ignores any usage info from the substituted
1073 -- function, but I don't think that matters. If it does
1076 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1077 -- ToDo: adjust for System IF
1078 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1079 doBeta fn args = mkApps fn args
1081 -- The function is almost always a variable, but not always.
1082 -- In particular, if this pass follows float-in,
1083 -- which it may, we can get
1084 -- (let f = ...f... in f) arg1 arg2
1085 scApp env (other_fn, args)
1086 = do { (fn_usg, fn') <- scExpr env other_fn
1087 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1088 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1090 ----------------------
1091 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1092 scTopBind env (Rec prs)
1093 | Just threshold <- sc_size env
1095 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1096 -- No specialisation
1097 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1098 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1099 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1100 | otherwise -- Do specialisation
1101 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1102 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1104 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1105 ; let rhs_usg = combineUsages rhs_usgs
1107 ; (_, specs) <- specLoop rhs_env2 force_spec
1108 (scu_calls rhs_usg) rhs_infos nullUsage
1109 [SI [] 0 Nothing | _ <- bndrs]
1111 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1112 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1114 (bndrs,rhss) = unzip prs
1115 force_spec = any (forceSpecBndr env) bndrs
1116 -- Note [Forcing specialisation]
1118 scTopBind env (NonRec bndr rhs)
1119 = do { (_, rhs') <- scExpr env rhs
1120 ; let (env1, bndr') = extendBndr env bndr
1121 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1122 ; return (env2, NonRec bndr' rhs') }
1124 ----------------------
1125 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1126 scRecRhs env (bndr,rhs)
1127 = do { let (arg_bndrs,body) = collectBinders rhs
1128 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1129 ; (body_usg, body') <- scExpr body_env body
1130 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1131 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1132 arg_bndrs body arg_occs) }
1133 -- The arg_occs says how the visible,
1134 -- lambda-bound binders of the RHS are used
1135 -- (including the TyVar binders)
1136 -- Two pats are the same if they match both ways
1138 ----------------------
1139 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1140 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1141 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1142 [(fn `addIdSpecialisations` rules, new_rhs)]
1144 rules = [r | OS _ r _ _ <- specs]
1146 ----------------------
1147 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1149 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1150 , scu_occs = unitVarEnv v use }
1151 | otherwise = nullUsage
1155 %************************************************************************
1157 The specialiser itself
1159 %************************************************************************
1162 data RhsInfo = RI OutId -- The binder
1163 OutExpr -- The new RHS
1164 [InVar] InExpr -- The *original* RHS (\xs.body)
1165 -- Note [Specialise original body]
1166 [ArgOcc] -- Info on how the xs occur in body
1168 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1170 Int -- Length of specs; used for numbering them
1172 (Maybe ScUsage) -- Nothing => we have generated specialisations
1173 -- from calls in the *original* RHS
1174 -- Just cs => we haven't, and this is the usage
1175 -- of the original RHS
1176 -- See Note [Local recursive groups]
1178 -- One specialisation: Rule plus definition
1179 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1180 CoreRule -- Rule connecting original id with the specialisation
1181 OutId OutExpr -- Spec id + its rhs
1185 -> Bool -- force specialisation?
1186 -- Note [Forcing specialisation]
1189 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1190 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1191 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1192 = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1193 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1194 new_usg = combineUsages new_usg_s
1195 new_calls = scu_calls new_usg
1196 all_usg = usg_so_far `combineUsage` new_usg
1197 ; if isEmptyVarEnv new_calls then
1198 return (all_usg, all_specs)
1200 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1204 -> Bool -- force specialisation?
1205 -- Note [Forcing specialisation]
1206 -> CallEnv -- Info on calls
1208 -> SpecInfo -- Original RHS plus patterns dealt with
1209 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1211 -- Note: the rhs here is the optimised version of the original rhs
1212 -- So when we make a specialised copy of the RHS, we're starting
1213 -- from an RHS whose nested functions have been optimised already.
1215 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
1216 spec_info@(SI specs spec_count mb_unspec)
1217 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1218 , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
1219 , notNull arg_bndrs -- Only specialise functions
1220 , Just all_calls <- lookupVarEnv bind_calls fn
1221 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1222 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1223 -- , text "arg_occs" <+> ppr arg_occs
1224 -- , text "calls" <+> ppr all_calls
1225 -- , text "good pats" <+> ppr pats]) $
1228 -- Bale out if too many specialisations
1229 ; let n_pats = length pats
1230 spec_count' = n_pats + spec_count
1231 ; case sc_count env of
1232 Just max | not force_spec && spec_count' > max
1233 -> pprTrace "SpecConstr" msg $
1234 return (nullUsage, spec_info)
1236 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1237 , nest 2 (ptext (sLit "has") <+>
1238 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1239 ptext (sLit "but the limit is") <+> int max) ]
1240 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1242 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1243 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1245 _normal_case -> do {
1247 let spec_env = decreaseSpecCount env n_pats
1248 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1249 (pats `zip` [spec_count..])
1250 -- See Note [Specialise original body]
1252 ; let spec_usg = combineUsages spec_usgs
1253 (new_usg, mb_unspec')
1255 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1256 _ -> (spec_usg, mb_unspec)
1258 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1260 = return (nullUsage, spec_info) -- The boring case
1263 ---------------------
1265 -> OutId -- Function
1266 -> [InVar] -- Lambda-binders of RHS; should match patterns
1267 -> InExpr -- Body of the original function
1269 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1271 -- spec_one creates a specialised copy of the function, together
1272 -- with a rule for using it. I'm very proud of how short this
1273 -- function is, considering what it does :-).
1279 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1280 [c::*, v::(b,c) are presumably bound by the (...) part]
1282 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1283 (...entire body of f...) [b -> (b,c),
1284 y -> ((:) (a,(b,c)) (x,v) hw)]
1286 RULE: forall b::* c::*, -- Note, *not* forall a, x
1290 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1293 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1294 = do { spec_uniq <- getUniqueUs
1295 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1296 (arg_bndrs `zip` pats)
1298 fn_loc = nameSrcSpan fn_name
1299 spec_occ = mkSpecOcc (nameOccName fn_name)
1300 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1301 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1302 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1305 -- Specialise the body
1306 ; (spec_usg, spec_body) <- scExpr spec_env body
1308 -- ; pprTrace "done spec_one}" (ppr fn) $
1311 -- And build the results
1312 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1313 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1314 `setIdArity` count isId spec_lam_args
1315 spec_str = calcSpecStrictness fn spec_lam_args pats
1316 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1317 -- Usual w/w hack to avoid generating
1318 -- a spec_rhs of unlifted type and no args
1320 spec_rhs = mkLams spec_lam_args spec_body
1321 body_ty = exprType spec_body
1322 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1323 inline_act = idInlineActivation fn
1324 rule = mkRule True {- Auto -} True {- Local -}
1325 rule_name inline_act fn_name qvars pats rule_rhs
1326 -- See Note [Transfer activation]
1327 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1329 calcSpecStrictness :: Id -- The original function
1330 -> [Var] -> [CoreExpr] -- Call pattern
1331 -> StrictSig -- Strictness of specialised thing
1332 -- See Note [Transfer strictness]
1333 calcSpecStrictness fn qvars pats
1334 = StrictSig (mkTopDmdType spec_dmds TopRes)
1336 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1337 StrictSig (DmdType _ dmds _) = idStrictness fn
1339 dmd_env = go emptyVarEnv dmds pats
1341 go env ds (Type {} : pats) = go env ds pats
1342 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1345 go_one env d (Var v) = extendVarEnv_C both env v d
1346 go_one env (Box d) e = go_one env d e
1347 go_one env (Eval (Prod ds)) e
1348 | (Var _, args) <- collectArgs e = go env ds args
1349 go_one env _ _ = env
1353 Note [Specialise original body]
1354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1355 The RhsInfo for a binding keeps the *original* body of the binding. We
1356 must specialise that, *not* the result of applying specExpr to the RHS
1357 (which is also kept in RhsInfo). Otherwise we end up specialising a
1358 specialised RHS, and that can lead directly to exponential behaviour.
1360 Note [Transfer activation]
1361 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1362 This note is for SpecConstr, but exactly the same thing
1363 happens in the overloading specialiser; see
1364 Note [Auto-specialisation and RULES] in Specialise.
1366 In which phase should the specialise-constructor rules be active?
1367 Originally I made them always-active, but Manuel found that this
1368 defeated some clever user-written rules. Then I made them active only
1369 in Phase 0; after all, currently, the specConstr transformation is
1370 only run after the simplifier has reached Phase 0, but that meant
1371 that specialisations didn't fire inside wrappers; see test
1372 simplCore/should_compile/spec-inline.
1374 So now I just use the inline-activation of the parent Id, as the
1375 activation for the specialiation RULE, just like the main specialiser;
1377 This in turn means there is no point in specialising NOINLINE things,
1378 so we test for that.
1380 Note [Transfer strictness]
1381 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1382 We must transfer strictness information from the original function to
1383 the specialised one. Suppose, for example
1386 and a RULE f (a:as) b = f_spec a as b
1388 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1389 when calling f_spec instead of call-by-value. And that can result in
1390 unbounded worsening in space (cf the classic foldl vs foldl')
1392 See Trac #3437 for a good example.
1394 The function calcSpecStrictness performs the calculation.
1397 %************************************************************************
1399 \subsection{Argument analysis}
1401 %************************************************************************
1403 This code deals with analysing call-site arguments to see whether
1404 they are constructor applications.
1408 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1411 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1412 -- Result has no duplicate patterns,
1413 -- nor ones mentioned in done_pats
1414 -- Bool indicates that there was at least one boring pattern
1415 callsToPats env done_specs bndr_occs calls
1416 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1418 ; let good_pats :: [([Var], [CoreArg])]
1419 good_pats = catMaybes mb_pats
1420 done_pats = [p | OS p _ _ _ <- done_specs]
1421 is_done p = any (samePat p) done_pats
1423 ; return (any isNothing mb_pats,
1424 filterOut is_done (nubBy samePat good_pats)) }
1426 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1427 -- The [Var] is the variables to quantify over in the rule
1428 -- Type variables come first, since they may scope
1429 -- over the following term variables
1430 -- The [CoreExpr] are the argument patterns for the rule
1431 callToPats env bndr_occs (con_env, args)
1432 | length args < length bndr_occs -- Check saturated
1435 = do { let in_scope = substInScope (sc_subst env)
1436 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1437 ; let (interesting_s, pats) = unzip prs
1438 pat_fvs = varSetElems (exprsFreeVars pats)
1439 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1440 -- Quantify over variables that are not in sccpe
1442 -- See Note [Shadowing] at the top
1444 (tvs, ids) = partition isTyCoVar qvars
1446 -- Put the type variables first; the type of a term
1447 -- variable may mention a type variable
1449 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1451 then return (Just (qvars', pats))
1452 else return Nothing }
1454 -- argToPat takes an actual argument, and returns an abstracted
1455 -- version, consisting of just the "constructor skeleton" of the
1456 -- argument, with non-constructor sub-expression replaced by new
1457 -- placeholder variables. For example:
1458 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1461 -> InScopeSet -- What's in scope at the fn defn site
1462 -> ValueEnv -- ValueEnv at the call site
1463 -> CoreArg -- A call arg (or component thereof)
1465 -> UniqSM (Bool, CoreArg)
1466 -- Returns (interesting, pat),
1467 -- where pat is the pattern derived from the argument
1468 -- intersting=True if the pattern is non-trivial (not a variable or type)
1469 -- E.g. x:xs --> (True, x:xs)
1470 -- f xs --> (False, w) where w is a fresh wildcard
1471 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1472 -- \x. x+y --> (True, \x. x+y)
1473 -- lvl7 --> (True, lvl7) if lvl7 is bound
1474 -- somewhere further out
1476 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1477 = return (False, arg)
1479 argToPat env in_scope val_env (Note _ arg) arg_occ
1480 = argToPat env in_scope val_env arg arg_occ
1481 -- Note [Notes in call patterns]
1482 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1483 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1484 -- Perhaps we should not ignore profiling notes, but I'm going to
1485 -- ride roughshod over them all for now.
1486 --- See Note [Notes in RULE matching] in Rules
1488 argToPat env in_scope val_env (Let _ arg) arg_occ
1489 = argToPat env in_scope val_env arg arg_occ
1490 -- See Note [Matching lets] in Rule.lhs
1491 -- Look through let expressions
1492 -- e.g. f (let v = rhs in (v,w))
1493 -- Here we can specialise for f (v,w)
1494 -- because the rule-matcher will look through the let.
1496 {- Disabled; see Note [Matching cases] in Rule.lhs
1497 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1498 | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
1499 = argToPat env in_scope val_env rhs arg_occ
1502 argToPat env in_scope val_env (Cast arg co) arg_occ
1503 | not (ignoreType env ty2)
1504 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1505 ; if not interesting then
1508 { -- Make a wild-card pattern for the coercion
1510 ; let co_name = mkSysTvName uniq (fsLit "sg")
1511 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1512 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1514 (ty1, ty2) = coercionKind co
1518 {- Disabling lambda specialisation for now
1519 It's fragile, and the spec_loop can be infinite
1520 argToPat in_scope val_env arg arg_occ
1522 = return (True, arg)
1524 is_value_lam (Lam v e) -- Spot a value lambda, even if
1525 | isId v = True -- it is inside a type lambda
1526 | otherwise = is_value_lam e
1527 is_value_lam other = False
1530 -- Check for a constructor application
1531 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1532 argToPat env in_scope val_env arg arg_occ
1533 | Just (ConVal dc args) <- isValue val_env arg
1534 , not (ignoreAltCon env dc)
1536 ScrutOcc _ -> True -- Used only by case scrutinee
1537 BothOcc -> case arg of -- Used elsewhere
1538 App {} -> True -- see Note [Reboxing]
1540 _other -> False -- No point; the arg is not decomposed
1541 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1542 ; return (True, mk_con_app dc (map snd args')) }
1544 -- Check if the argument is a variable that
1545 -- is in scope at the function definition site
1546 -- It's worth specialising on this if
1547 -- (a) it's used in an interesting way in the body
1548 -- (b) we know what its value is
1549 argToPat env in_scope val_env (Var v) arg_occ
1550 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1552 not (ignoreType env (varType v))
1553 = return (True, Var v)
1556 | isLocalId v = v `elemInScopeSet` in_scope
1557 && isJust (lookupVarEnv val_env v)
1558 -- Local variables have values in val_env
1559 | otherwise = isValueUnfolding (idUnfolding v)
1560 -- Imports have unfoldings
1562 -- I'm really not sure what this comment means
1563 -- And by not wild-carding we tend to get forall'd
1564 -- variables that are in soope, which in turn can
1565 -- expose the weakness in let-matching
1566 -- See Note [Matching lets] in Rules
1568 -- Check for a variable bound inside the function.
1569 -- Don't make a wild-card, because we may usefully share
1570 -- e.g. f a = let x = ... in f (x,x)
1571 -- NB: this case follows the lambda and con-app cases!!
1572 -- argToPat _in_scope _val_env (Var v) _arg_occ
1573 -- = return (False, Var v)
1574 -- SLPJ : disabling this to avoid proliferation of versions
1575 -- also works badly when thinking about seeding the loop
1576 -- from the body of the let
1577 -- f x y = letrec g z = ... in g (x,y)
1578 -- We don't want to specialise for that *particular* x,y
1580 -- The default case: make a wild-card
1581 argToPat _env _in_scope _val_env arg _arg_occ
1582 = wildCardPat (exprType arg)
1584 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1585 wildCardPat ty = do { uniq <- getUniqueUs
1586 ; let id = mkSysLocal (fsLit "sc") uniq ty
1587 ; return (False, Var id) }
1589 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1590 -> [(CoreArg, ArgOcc)]
1591 -> UniqSM [(Bool, CoreArg)]
1592 argsToPats env in_scope val_env args
1595 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1600 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1601 isValue _env (Lit lit)
1602 = Just (ConVal (LitAlt lit) [])
1605 | Just stuff <- lookupVarEnv env v
1606 = Just stuff -- You might think we could look in the idUnfolding here
1607 -- but that doesn't take account of which branch of a
1608 -- case we are in, which is the whole point
1610 | not (isLocalId v) && isCheapUnfolding unf
1611 = isValue env (unfoldingTemplate unf)
1614 -- However we do want to consult the unfolding
1615 -- as well, for let-bound constructors!
1617 isValue env (Lam b e)
1618 | isTyCoVar b = case isValue env e of
1619 Just _ -> Just LambdaVal
1621 | otherwise = Just LambdaVal
1623 isValue _env expr -- Maybe it's a constructor application
1624 | (Var fun, args) <- collectArgs expr
1625 = case isDataConWorkId_maybe fun of
1627 Just con | args `lengthAtLeast` dataConRepArity con
1628 -- Check saturated; might be > because the
1629 -- arity excludes type args
1630 -> Just (ConVal (DataAlt con) args)
1632 _other | valArgCount args < idArity fun
1633 -- Under-applied function
1634 -> Just LambdaVal -- Partial application
1638 isValue _env _expr = Nothing
1640 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1641 mk_con_app (LitAlt lit) [] = Lit lit
1642 mk_con_app (DataAlt con) args = mkConApp con args
1643 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1645 samePat :: CallPat -> CallPat -> Bool
1646 samePat (vs1, as1) (vs2, as2)
1649 same (Var v1) (Var v2)
1650 | v1 `elem` vs1 = v2 `elem` vs2
1651 | v2 `elem` vs2 = False
1652 | otherwise = v1 == v2
1654 same (Lit l1) (Lit l2) = l1==l2
1655 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1657 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1658 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1659 same (Cast e1 _) e2 = same e1 e2
1660 same e1 (Note _ e2) = same e1 e2
1661 same e1 (Cast e2 _) = same e1 e2
1663 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1664 False -- Let, lambda, case should not occur
1665 bad (Case {}) = True
1671 Note [Ignore type differences]
1672 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1673 We do not want to generate specialisations where the call patterns
1674 differ only in their type arguments! Not only is it utterly useless,
1675 but it also means that (with polymorphic recursion) we can generate
1676 an infinite number of specialisations. Example is Data.Sequence.adjustTree,