2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SpecConstr]{Specialise over constructors}
11 #include "HsVersions.h"
16 import CoreUnfold ( couldBeSmallEnoughToInline )
17 import CoreLint ( showPass, endPass )
18 import CoreFVs ( exprsFreeVars )
19 import CoreTidy ( tidyRules )
20 import PprCore ( pprRules )
21 import WwLib ( mkWorkerArgs )
22 import DataCon ( dataConRepArity, dataConUnivTyVars )
23 import Type ( Type, tyConAppArgs )
24 import Coercion ( coercionKind )
25 import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
26 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
31 import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
32 import OccName ( mkSpecOcc )
33 import ErrUtils ( dumpIfSet_dyn )
34 import DynFlags ( DynFlags(..), DynFlag(..) )
35 import BasicTypes ( Activation(..) )
36 import Maybes ( orElse, catMaybes, isJust )
38 import List ( nubBy, partition )
45 -----------------------------------------------------
47 -----------------------------------------------------
52 drop n (x:xs) = drop (n-1) xs
54 After the first time round, we could pass n unboxed. This happens in
55 numerical code too. Here's what it looks like in Core:
57 drop n xs = case xs of
62 _ -> drop (I# (n# -# 1#)) xs
64 Notice that the recursive call has an explicit constructor as argument.
65 Noticing this, we can make a specialised version of drop
67 RULE: drop (I# n#) xs ==> drop' n# xs
69 drop' n# xs = let n = I# n# in ...orig RHS...
71 Now the simplifier will apply the specialisation in the rhs of drop', giving
73 drop' n# xs = case xs of
77 _ -> drop (n# -# 1#) xs
81 We'd also like to catch cases where a parameter is carried along unchanged,
82 but evaluated each time round the loop:
84 f i n = if i>0 || i>n then i else f (i*2) n
86 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
87 In Core, by the time we've w/wd (f is strict in i) we get
89 f i# n = case i# ># 0 of
91 True -> case n of n' { I# n# ->
94 True -> f (i# *# 2#) n'
96 At the call to f, we see that the argument, n is know to be (I# n#),
97 and n is evaluated elsewhere in the body of f, so we can play the same
103 We must be careful not to allocate the same constructor twice. Consider
104 f p = (...(case p of (a,b) -> e)...p...,
105 ...let t = (r,s) in ...t...(f t)...)
106 At the recursive call to f, we can see that t is a pair. But we do NOT want
107 to make a specialised copy:
108 f' a b = let p = (a,b) in (..., ...)
109 because now t is allocated by the caller, then r and s are passed to the
110 recursive call, which allocates the (r,s) pair again.
113 (a) the argument p is used in other than a case-scrutinsation way.
114 (b) the argument to the call is not a 'fresh' tuple; you have to
115 look into its unfolding to see that it's a tuple
117 Hence the "OR" part of Note [Good arguments] below.
119 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
120 allocation, but does perhaps save evals. In the RULE we'd have
123 f (I# x#) = f' (I# x#) x#
125 If at the call site the (I# x) was an unfolding, then we'd have to
126 rely on CSE to eliminate the duplicate allocation.... This alternative
127 doesn't look attractive enough to pursue.
129 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
130 the conservative reboxing story prevents many useful functions from being
131 specialised. Example:
132 foo :: Maybe Int -> Int -> Int
134 foo x@(Just m) n = foo x (n-m)
135 Here the use of 'x' will clearly not require boxing in the specialised function.
137 The strictness analyser has the same problem, in fact. Example:
139 If we pass just 'a' and 'b' to the worker, it might need to rebox the
140 pair to create (a,b). A more sophisticated analysis might figure out
141 precisely the cases in which this could happen, but the strictness
142 analyser does no such analysis; it just passes 'a' and 'b', and hopes
145 So my current choice is to make SpecConstr similarly aggressive, and
146 ignore the bad potential of reboxing.
149 Note [Good arguments]
150 ~~~~~~~~~~~~~~~~~~~~~
153 * A self-recursive function. Ignore mutual recursion for now,
154 because it's less common, and the code is simpler for self-recursion.
158 a) At a recursive call, one or more parameters is an explicit
159 constructor application
161 That same parameter is scrutinised by a case somewhere in
162 the RHS of the function
166 b) At a recursive call, one or more parameters has an unfolding
167 that is an explicit constructor application
169 That same parameter is scrutinised by a case somewhere in
170 the RHS of the function
172 Those are the only uses of the parameter (see Note [Reboxing])
175 What to abstract over
176 ~~~~~~~~~~~~~~~~~~~~~
177 There's a bit of a complication with type arguments. If the call
180 f p = ...f ((:) [a] x xs)...
182 then our specialised function look like
184 f_spec x xs = let p = (:) [a] x xs in ....as before....
186 This only makes sense if either
187 a) the type variable 'a' is in scope at the top of f, or
188 b) the type variable 'a' is an argument to f (and hence fs)
190 Actually, (a) may hold for value arguments too, in which case
191 we may not want to pass them. Supose 'x' is in scope at f's
192 defn, but xs is not. Then we'd like
194 f_spec xs = let p = (:) [a] x xs in ....as before....
196 Similarly (b) may hold too. If x is already an argument at the
197 call, no need to pass it again.
199 Finally, if 'a' is not in scope at the call site, we could abstract
200 it as we do the term variables:
202 f_spec a x xs = let p = (:) [a] x xs in ...as before...
204 So the grand plan is:
206 * abstract the call site to a constructor-only pattern
207 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
209 * Find the free variables of the abstracted pattern
211 * Pass these variables, less any that are in scope at
212 the fn defn. But see Note [Shadowing] below.
215 NOTICE that we only abstract over variables that are not in scope,
216 so we're in no danger of shadowing variables used in "higher up"
222 In this pass we gather up usage information that may mention variables
223 that are bound between the usage site and the definition site; or (more
224 seriously) may be bound to something different at the definition site.
227 f x = letrec g y v = let x = ...
230 Since 'x' is in scope at the call site, we may make a rewrite rule that
232 RULE forall a,b. g (a,b) x = ...
233 But this rule will never match, because it's really a different 'x' at
234 the call site -- and that difference will be manifest by the time the
235 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
236 no-shadowing, so perhaps it may not be distinct?]
238 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
239 is to run deShadowBinds before running SpecConstr, but instead we run the
240 simplifier. That gives the simplest possible program for SpecConstr to
241 chew on; and it virtually guarantees no shadowing.
243 Note [Specialising for constant parameters]
244 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
245 This one is about specialising on a *constant* (but not necessarily
246 constructor) argument
248 foo :: Int -> (Int -> Int) -> Int
250 foo m f = foo (f m) (+1)
254 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
256 \ (ds_dlk :: GHC.Base.Int) ->
257 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
258 GHC.Base.I# (GHC.Prim.+# x_alG 1)
260 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
263 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
264 case ww_sme of ds_Xlw {
266 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
267 T.$wfoo ww1_Xmz lvl_rmV
272 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
273 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
275 When is this worth it? Call the constant 'lvl'
276 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
277 parameter is scrutinised anywhere in the body.
279 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
280 parameter is applied (...to enough arguments...?)
282 Also do this is if the function has RULES?
286 Note [Specialising for lambda parameters]
287 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
288 foo :: Int -> (Int -> Int) -> Int
290 foo m f = foo (f m) (\n -> n-m)
292 This is subtly different from the previous one in that we get an
293 explicit lambda as the argument:
295 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
298 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
299 case ww_sm8 of ds_Xlr {
301 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
304 (\ (n_ad3 :: GHC.Base.Int) ->
305 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
306 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
312 I wonder if SpecConstr couldn't be extended to handle this? After all,
313 lambda is a sort of constructor for functions and perhaps it already
314 has most of the necessary machinery?
316 Furthermore, there's an immediate win, because you don't need to allocate the lamda
317 at the call site; and if perchance it's called in the recursive call, then you
318 may avoid allocating it altogether. Just like for constructors.
320 Looks cool, but probably rare...but it might be easy to implement.
323 Note [SpecConstr for casts]
324 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 data instance T Int = T Int
332 go (T n) = go (T (n-1))
334 The recursive call ends up looking like
335 go (T (I# ...) `cast` g)
336 So we want to spot the construtor application inside the cast.
337 That's why we have the Cast case in argToPat
340 -----------------------------------------------------
341 Stuff not yet handled
342 -----------------------------------------------------
344 Here are notes arising from Roman's work that I don't want to lose.
350 foo :: Int -> T Int -> Int
352 foo x t | even x = case t of { T n -> foo (x-n) t }
353 | otherwise = foo (x-1) t
355 SpecConstr does no specialisation, because the second recursive call
356 looks like a boxed use of the argument. A pity.
358 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
360 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
361 case ww_sFo of ds_Xw6 [Just L] {
363 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
364 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
366 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
367 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
368 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
374 data a :*: b = !a :*: !b
377 foo :: (Int :*: T Int) -> Int
379 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
380 | otherwise = foo ((x-1) :*: t)
382 Very similar to the previous one, except that the parameters are now in
383 a strict tuple. Before SpecConstr, we have
385 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
387 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
389 case ww_sFU of ds_Xws [Just L] {
391 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
393 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
394 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
397 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
398 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
399 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
403 We get two specialisations:
404 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
405 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
406 = Foo.$s$wfoo1 a_sFB sc_sGC ;
407 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
408 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
409 = Foo.$s$wfoo y_aFp sc_sGC ;
411 But perhaps the first one isn't good. After all, we know that tpl_B2 is
412 a T (I# x) really, because T is strict and Int has one constructor. (We can't
413 unbox the strict fields, becuase T is polymorphic!)
417 %************************************************************************
419 \subsection{Top level wrapper stuff}
421 %************************************************************************
424 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
425 specConstrProgram dflags us binds
427 showPass dflags "SpecConstr"
429 let (binds', _) = initUs us (go (initScEnv dflags) binds)
431 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
433 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
434 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
438 go env [] = returnUs []
439 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
440 go env' binds `thenUs` \ binds' ->
441 returnUs (bind' : binds')
445 %************************************************************************
447 \subsection{Environment: goes downwards}
449 %************************************************************************
452 data ScEnv = SCE { sc_size :: Int, -- Size threshold
454 sc_subst :: Subst, -- Current substitution
456 sc_how_bound :: HowBoundEnv,
457 -- Binds interesting non-top-level variables
458 -- Domain is OutVars (*after* applying the substitution)
461 -- Domain is OutIds (*after* applying the substitution)
462 -- Used even for top-level bindings (but not imported ones)
465 ---------------------
466 -- As we go, we apply a substitution (sc_subst) to the current term
467 type InExpr = CoreExpr -- *Before* applying the subst
469 type OutExpr = CoreExpr -- *After* applying the subst
473 ---------------------
474 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
476 ---------------------
477 type ValueEnv = IdEnv Value -- Domain is OutIds
478 data Value = ConVal AltCon [CoreArg] -- *Saturated* constructors
479 | LambdaVal -- Inlinable lambdas or PAPs
481 instance Outputable Value where
482 ppr (ConVal con args) = ppr con <+> interpp'SP args
483 ppr LambdaVal = ptext SLIT("<Lambda>")
485 ---------------------
487 = SCE { sc_size = specThreshold dflags,
488 sc_subst = emptySubst,
489 sc_how_bound = emptyVarEnv,
490 sc_vals = emptyVarEnv }
492 data HowBound = RecFun -- These are the recursive functions for which
493 -- we seek interesting call patterns
495 | RecArg -- These are those functions' arguments, or their sub-components;
496 -- we gather occurrence information for these
498 instance Outputable HowBound where
499 ppr RecFun = text "RecFun"
500 ppr RecArg = text "RecArg"
502 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
503 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
505 scSubstId :: ScEnv -> Id -> CoreExpr
506 scSubstId env v = lookupIdSubst (sc_subst env) v
508 scSubstTy :: ScEnv -> Type -> Type
509 scSubstTy env ty = substTy (sc_subst env) ty
511 zapScSubst :: ScEnv -> ScEnv
512 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
514 extendScInScope :: ScEnv -> [Var] -> ScEnv
515 -- Bring the quantified variables into scope
516 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
518 extendScSubst :: ScEnv -> [(Var,CoreArg)] -> ScEnv
519 -- Extend the substitution
520 extendScSubst env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
522 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
523 extendHowBound env bndrs how_bound
524 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
525 [(bndr,how_bound) | bndr <- bndrs] }
527 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
528 extendBndrsWith how_bound env bndrs
529 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
531 (subst', bndrs') = substBndrs (sc_subst env) bndrs
532 hb_env' = sc_how_bound env `extendVarEnvList`
533 [(bndr,how_bound) | bndr <- bndrs']
535 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
536 extendBndrWith how_bound env bndr
537 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
539 (subst', bndr') = substBndr (sc_subst env) bndr
540 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
542 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
543 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
545 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
547 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
548 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
550 (subst', bndr') = substBndr (sc_subst env) bndr
552 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
553 extendValEnv env id Nothing = env
554 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
556 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
560 -- we want to bind b, and perhaps scrut too, to (C x y)
561 -- NB: Extends only the sc_vals part of the envt
562 extendCaseBndrs env scrut case_bndr con alt_bndrs
564 Var v -> extendValEnv env1 v cval
567 env1 = extendValEnv env case_bndr cval
570 LitAlt lit -> Just (ConVal con [])
571 DataAlt dc -> Just (ConVal con vanilla_args)
573 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
574 varsToCoreExprs alt_bndrs
578 %************************************************************************
580 \subsection{Usage information: flows upwards}
582 %************************************************************************
587 calls :: CallEnv, -- Calls
588 -- The functions are a subset of the
589 -- RecFuns in the ScEnv
591 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
592 } -- The variables are a subset of the
593 -- RecArg in the ScEnv
595 type CallEnv = IdEnv [Call]
596 type Call = (ValueEnv, [CoreArg])
597 -- The arguments of the call, together with the
598 -- env giving the constructor bindings at the call site
600 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
602 combineCalls :: CallEnv -> CallEnv -> CallEnv
603 combineCalls = plusVarEnv_C (++)
605 combineUsage u1 u2 = SCU { calls = combineCalls (calls u1) (calls u2),
606 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
608 combineUsages [] = nullUsage
609 combineUsages us = foldr1 combineUsage us
611 lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
612 lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
613 = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
614 lookupVarEnv sc_occs bndr `orElse` NoOcc)
616 lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
617 lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
618 = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
619 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
621 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
622 | UnkOcc -- Used in some unknown way
624 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
626 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
630 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
631 is *only* taken apart or applied.
633 Functions, literal: ScrutOcc emptyUFM
634 Data constructors: ScrutOcc subs,
636 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
637 The domain of the UniqFM is the Unique of the data constructor
639 The [ArgOcc] is the occurrences of the *pattern-bound* components
640 of the data structure. E.g.
641 data T a = forall b. MkT a b (b->a)
642 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
646 instance Outputable ArgOcc where
647 ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
648 ppr UnkOcc = ptext SLIT("unk-occ")
649 ppr BothOcc = ptext SLIT("both-occ")
650 ppr NoOcc = ptext SLIT("no-occ")
652 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
653 -- that if the thing is scrutinised anywhere then we get to see that
654 -- in the overall result, even if it's also used in a boxed way
655 -- This might be too agressive; see Note [Reboxing] Alternative 3
656 combineOcc NoOcc occ = occ
657 combineOcc occ NoOcc = occ
658 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
659 combineOcc occ (ScrutOcc ys) = ScrutOcc ys
660 combineOcc (ScrutOcc xs) occ = ScrutOcc xs
661 combineOcc UnkOcc UnkOcc = UnkOcc
662 combineOcc _ _ = BothOcc
664 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
665 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
667 setScrutOcc :: ScEnv -> ScUsage -> CoreExpr -> ArgOcc -> ScUsage
668 -- *Overwrite* the occurrence info for the scrutinee, if the scrutinee
669 -- is a variable, and an interesting variable
670 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
671 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
672 setScrutOcc env usg (Var v) occ
673 | Just RecArg <- lookupHowBound env v = usg { occs = extendVarEnv (occs usg) v occ }
675 setScrutOcc env usg other occ -- Catch-all
678 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
679 -- Find usage of components of data con; returns [UnkOcc...] if unknown
680 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
682 conArgOccs (ScrutOcc fm) (DataAlt dc)
683 | Just pat_arg_occs <- lookupUFM fm dc
684 = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs
686 conArgOccs other con = repeat UnkOcc
689 %************************************************************************
691 \subsection{The main recursive function}
693 %************************************************************************
695 The main recursive function gathers up usage information, and
696 creates specialised versions of functions.
699 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
700 -- The unique supply is needed when we invent
701 -- a new name for the specialised function and its args
703 scExpr env e = scExpr' env e
706 scExpr' env (Var v) = case scSubstId env v of
707 Var v' -> returnUs (varUsage env v UnkOcc, Var v')
708 e' -> scExpr (zapScSubst env) e'
710 scExpr' env e@(Type t) = returnUs (nullUsage, Type (scSubstTy env t))
711 scExpr' env e@(Lit l) = returnUs (nullUsage, e)
712 scExpr' env (Note n e) = do { (usg,e') <- scExpr env e
713 ; return (usg, Note n e') }
714 scExpr' env (Cast e co) = do { (usg, e') <- scExpr env e
715 ; return (usg, Cast e' (scSubstTy env co)) }
716 scExpr' env (Lam b e) = do { let (env', b') = extendBndr env b
717 ; (usg, e') <- scExpr env' e
718 ; return (usg, Lam b' e') }
720 scExpr' env (Case scrut b ty alts)
721 = do { (scrut_usg, scrut') <- scExpr env scrut
722 ; case isValue (sc_vals env) scrut' of
723 Just (ConVal con args) -> sc_con_app con args scrut'
724 other -> sc_vanilla scrut_usg scrut'
727 sc_con_app con args scrut' -- Known constructor; simplify
728 = do { let (_, bs, rhs) = findAlt con alts
729 alt_env' = extendScSubst env ((b,scrut') : bs `zip` trimConArgs con args)
730 ; scExpr alt_env' rhs }
732 sc_vanilla scrut_usg scrut' -- Normal case
733 = do { let (alt_env,b') = extendBndrWith RecArg env b
734 -- Record RecArg for the components
736 ; (alt_usgs, alt_occs, alts')
737 <- mapAndUnzip3Us (sc_alt alt_env scrut' b') alts
739 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
740 scrut_occ = foldr combineOcc b_occ alt_occs
741 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
742 -- The combined usage of the scrutinee is given
743 -- by scrut_occ, which is passed to scScrut, which
744 -- in turn treats a bare-variable scrutinee specially
746 ; return (alt_usg `combineUsage` scrut_usg',
747 Case scrut' b' (scSubstTy env ty) alts') }
749 sc_alt env scrut' b' (con,bs,rhs)
750 = do { let (env1, bs') = extendBndrsWith RecArg env bs
751 env2 = extendCaseBndrs env1 scrut' b' con bs'
752 ; (usg,rhs') <- scExpr env2 rhs
753 ; let (usg', arg_occs) = lookupOccs usg bs
754 scrut_occ = case con of
755 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
756 other -> ScrutOcc emptyUFM
757 ; return (usg', scrut_occ, (con,bs',rhs')) }
759 scExpr' env (Let (NonRec bndr rhs) body)
760 = do { let (body_env, bndr') = extendBndr env bndr
761 ; (rhs_usg, rhs_info@(_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
763 ; if null args' || isEmptyVarEnv (calls rhs_usg) then do
765 let rhs' = mkLams args' rhs_body'
766 body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
767 -- Record if the RHS is a value
768 ; (body_usg, body') <- scExpr body_env2 body
769 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
771 do { -- Join-point case
772 let body_env2 = extendHowBound body_env [bndr'] RecFun
773 -- If the RHS of this 'let' contains calls
774 -- to recursive functions that we're trying
775 -- to specialise, then treat this let too
776 -- as one to specialise
777 ; (body_usg, body') <- scExpr body_env2 body
779 ; (spec_usg, _, specs) <- specialise env (calls body_usg) ([], rhs_info)
781 ; return (body_usg { calls = calls body_usg `delVarEnv` bndr' }
782 `combineUsage` rhs_usg `combineUsage` spec_usg,
783 mkLets [NonRec b r | (b,r) <- addRules rhs_info specs] body')
786 scExpr' env (Let (Rec prs) body)
787 = do { (env', bind_usg, bind') <- scBind env (Rec prs)
788 ; (body_usg, body') <- scExpr env' body
789 ; return (bind_usg `combineUsage` body_usg, Let bind' body') }
791 scExpr' env e@(App _ _)
792 = do { let (fn, args) = collectArgs e
793 ; (fn_usg, fn') <- scExpr env fn
794 -- Process the function too. It's almost always a variable,
795 -- but not always. In particular, if this pass follows float-in,
796 -- which it may, we can get
797 -- (let f = ...f... in f) arg1 arg2
798 -- Also the substitution may replace a variable by a non-variable
800 ; let fn_usg' = setScrutOcc env fn_usg fn' (ScrutOcc emptyUFM)
801 -- We use setScrutOcc to record the fact that the function is called
802 -- Perhaps we should check that it has at least one value arg,
803 -- but currently we don't bother
805 ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
806 ; let call_usg = case fn' of
807 Var f | Just RecFun <- lookupHowBound env f
808 , not (null args) -- Not a proper call!
809 -> SCU { calls = unitVarEnv f [(sc_vals env, args')],
812 ; return (combineUsages arg_usgs `combineUsage` fn_usg'
813 `combineUsage` call_usg,
817 ----------------------
818 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
820 | not (all (couldBeSmallEnoughToInline (sc_size env)) rhss)
822 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
823 ; (rhs_usgs, rhss') <- mapAndUnzipUs (scExpr rhs_env) rhss
824 ; return (rhs_env, combineUsages rhs_usgs, Rec (bndrs' `zip` rhss')) }
825 | otherwise -- Do specialisation
826 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
827 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
829 ; (rhs_usgs, rhs_infos) <- mapAndUnzipUs (scRecRhs rhs_env2) (bndrs' `zip` rhss)
830 ; let rhs_usg = combineUsages rhs_usgs
832 ; (spec_usg, specs) <- spec_loop rhs_env2 (calls rhs_usg)
833 (repeat [] `zip` rhs_infos)
835 ; let all_usg = rhs_usg `combineUsage` spec_usg
837 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
838 all_usg { calls = calls rhs_usg `delVarEnvList` bndrs' },
839 Rec (concat (zipWith addRules rhs_infos specs))) }
841 (bndrs,rhss) = unzip prs
845 -> [([CallPat], RhsInfo)] -- One per binder
846 -> UniqSM (ScUsage, [[SpecInfo]]) -- One list per binder
847 spec_loop env all_calls rhs_stuff
848 = do { (spec_usg_s, new_pats_s, specs) <- mapAndUnzip3Us (specialise env all_calls) rhs_stuff
849 ; let spec_usg = combineUsages spec_usg_s
850 ; if all null new_pats_s then
851 return (spec_usg, specs) else do
852 { (spec_usg1, specs1) <- spec_loop env (calls spec_usg)
853 (zipWith add_pats new_pats_s rhs_stuff)
854 ; return (spec_usg `combineUsage` spec_usg1, zipWith (++) specs specs1) } }
856 add_pats :: [CallPat] -> ([CallPat], RhsInfo) -> ([CallPat], RhsInfo)
857 add_pats new_pats (done_pats, rhs_info) = (done_pats ++ new_pats, rhs_info)
859 scBind env (NonRec bndr rhs)
860 = do { (usg, rhs') <- scExpr env rhs
861 ; let (env1, bndr') = extendBndr env bndr
862 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
863 ; return (env2, usg, NonRec bndr' rhs') }
865 ----------------------
866 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
867 scRecRhs env (bndr,rhs)
868 = do { let (arg_bndrs,body) = collectBinders rhs
869 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
870 ; (body_usg, body') <- scExpr body_env body
871 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
872 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
874 -- The arg_occs says how the visible,
875 -- lambda-bound binders of the RHS are used
876 -- (including the TyVar binders)
877 -- Two pats are the same if they match both ways
879 ----------------------
880 addRules :: RhsInfo -> [SpecInfo] -> [(Id,CoreExpr)]
881 addRules (fn, args, body, _) specs
882 = [(id,rhs) | (_,id,rhs) <- specs] ++
883 [(fn `addIdSpecialisations` rules, mkLams args body)]
885 rules = [r | (r,_,_) <- specs]
887 ----------------------
889 | Just RecArg <- lookupHowBound env v = SCU { calls = emptyVarEnv,
890 occs = unitVarEnv v use }
891 | otherwise = nullUsage
895 %************************************************************************
897 The specialiser itself
899 %************************************************************************
902 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
903 -- Info about the *original* RHS of a binding we are specialising
904 -- Original binding f = \xs.body
905 -- Plus info about usage of arguments
907 type SpecInfo = (CoreRule, OutId, OutExpr)
908 -- One specialisation: Rule plus definition
913 -> CallEnv -- Info on calls
914 -> ([CallPat], RhsInfo) -- Original RHS plus patterns dealt with
915 -> UniqSM (ScUsage, [CallPat], [SpecInfo]) -- Specialised calls
917 -- Note: the rhs here is the optimised version of the original rhs
918 -- So when we make a specialised copy of the RHS, we're starting
919 -- from an RHS whose nested functions have been optimised already.
921 specialise env bind_calls (done_pats, (fn, arg_bndrs, body, arg_occs))
922 | notNull arg_bndrs, -- Only specialise functions
923 Just all_calls <- lookupVarEnv bind_calls fn
924 = do { pats <- callsToPats env done_pats arg_occs all_calls
925 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
926 -- text "calls" <+> ppr all_calls,
927 -- text "good pats" <+> ppr pats]) $
930 ; (spec_usgs, specs) <- mapAndUnzipUs (spec_one env fn arg_bndrs body)
931 (pats `zip` [length done_pats..])
933 ; return (combineUsages spec_usgs, pats, specs) }
935 = return (nullUsage, [], []) -- The boring case
938 ---------------------
941 -> [Var] -- Lambda-binders of RHS; should match patterns
942 -> CoreExpr -- Body of the original function
943 -> (([Var], [CoreArg]), Int)
944 -> UniqSM (ScUsage, SpecInfo) -- Rule and binding
946 -- spec_one creates a specialised copy of the function, together
947 -- with a rule for using it. I'm very proud of how short this
948 -- function is, considering what it does :-).
954 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
955 [c::*, v::(b,c) are presumably bound by the (...) part]
957 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
958 (...entire body of f...) [b -> (b,c),
959 y -> ((:) (a,(b,c)) (x,v) hw)]
961 RULE: forall b::* c::*, -- Note, *not* forall a, x
965 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
968 spec_one env fn arg_bndrs body ((qvars, pats), rule_number)
969 = do { -- Specialise the body
970 let spec_env = extendScSubst (extendScInScope env qvars)
971 (arg_bndrs `zip` pats)
972 ; (spec_usg, spec_body) <- scExpr spec_env body
974 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
975 -- text "calls" <+> (ppr (calls spec_usg))])
978 -- And build the results
979 ; spec_uniq <- getUniqueUs
980 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
981 -- Usual w/w hack to avoid generating
982 -- a spec_rhs of unlifted type and no args
985 fn_loc = nameSrcSpan fn_name
986 spec_occ = mkSpecOcc (nameOccName fn_name)
987 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
988 spec_rhs = mkLams spec_lam_args spec_body
989 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
990 body_ty = exprType spec_body
991 rule_rhs = mkVarApps (Var spec_id) spec_call_args
992 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
993 ; return (spec_usg, (rule, spec_id, spec_rhs)) }
995 -- In which phase should the specialise-constructor rules be active?
996 -- Originally I made them always-active, but Manuel found that
997 -- this defeated some clever user-written rules. So Plan B
998 -- is to make them active only in Phase 0; after all, currently,
999 -- the specConstr transformation is only run after the simplifier
1000 -- has reached Phase 0. In general one would want it to be
1001 -- flag-controllable, but for now I'm leaving it baked in
1003 specConstrActivation :: Activation
1004 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1007 %************************************************************************
1009 \subsection{Argument analysis}
1011 %************************************************************************
1013 This code deals with analysing call-site arguments to see whether
1014 they are constructor applications.
1018 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1021 callsToPats :: ScEnv -> [CallPat] -> [ArgOcc] -> [Call] -> UniqSM [CallPat]
1022 -- Result has no duplicate patterns,
1023 -- nor ones mentioned in done_pats
1024 callsToPats env done_pats bndr_occs calls
1025 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1027 ; let good_pats :: [([Var], [CoreArg])]
1028 good_pats = catMaybes mb_pats
1029 is_done p = any (samePat p) done_pats
1031 ; return (filterOut is_done (nubBy samePat good_pats)) }
1033 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1034 -- The [Var] is the variables to quantify over in the rule
1035 -- Type variables come first, since they may scope
1036 -- over the following term variables
1037 -- The [CoreExpr] are the argument patterns for the rule
1038 callToPats env bndr_occs (con_env, args)
1039 | length args < length bndr_occs -- Check saturated
1042 = do { let in_scope = substInScope (sc_subst env)
1043 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1044 ; let (good_pats, pats) = unzip prs
1045 pat_fvs = varSetElems (exprsFreeVars pats)
1046 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1047 -- Quantify over variables that are not in sccpe
1049 -- See Note [Shadowing] at the top
1051 (tvs, ids) = partition isTyVar qvars
1053 -- Put the type variables first; the type of a term
1054 -- variable may mention a type variable
1056 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1058 then return (Just (qvars', pats))
1059 else return Nothing }
1061 -- argToPat takes an actual argument, and returns an abstracted
1062 -- version, consisting of just the "constructor skeleton" of the
1063 -- argument, with non-constructor sub-expression replaced by new
1064 -- placeholder variables. For example:
1065 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1067 argToPat :: InScopeSet -- What's in scope at the fn defn site
1068 -> ValueEnv -- ValueEnv at the call site
1069 -> CoreArg -- A call arg (or component thereof)
1071 -> UniqSM (Bool, CoreArg)
1072 -- Returns (interesting, pat),
1073 -- where pat is the pattern derived from the argument
1074 -- intersting=True if the pattern is non-trivial (not a variable or type)
1075 -- E.g. x:xs --> (True, x:xs)
1076 -- f xs --> (False, w) where w is a fresh wildcard
1077 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1078 -- \x. x+y --> (True, \x. x+y)
1079 -- lvl7 --> (True, lvl7) if lvl7 is bound
1080 -- somewhere further out
1082 argToPat in_scope val_env arg@(Type ty) arg_occ
1083 = return (False, arg)
1085 argToPat in_scope val_env (Note n arg) arg_occ
1086 = argToPat in_scope val_env arg arg_occ
1087 -- Note [Notes in call patterns]
1088 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1089 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1090 -- Perhaps we should not ignore profiling notes, but I'm going to
1091 -- ride roughshod over them all for now.
1092 --- See Note [Notes in RULE matching] in Rules
1094 argToPat in_scope val_env (Let _ arg) arg_occ
1095 = argToPat in_scope val_env arg arg_occ
1096 -- Look through let expressions
1097 -- e.g. f (let v = rhs in \y -> ...v...)
1098 -- Here we can specialise for f (\y -> ...)
1099 -- because the rule-matcher will look through the let.
1101 argToPat in_scope val_env (Cast arg co) arg_occ
1102 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1103 ; if interesting then
1104 return (interesting, Cast arg' co)
1106 wildCardPat (snd (coercionKind co)) }
1108 {- Disabling lambda specialisation for now
1109 It's fragile, and the spec_loop can be infinite
1110 argToPat in_scope val_env arg arg_occ
1112 = return (True, arg)
1114 is_value_lam (Lam v e) -- Spot a value lambda, even if
1115 | isId v = True -- it is inside a type lambda
1116 | otherwise = is_value_lam e
1117 is_value_lam other = False
1120 -- Check for a constructor application
1121 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1122 argToPat in_scope val_env arg arg_occ
1123 | Just (ConVal dc args) <- isValue val_env arg
1125 ScrutOcc _ -> True -- Used only by case scrutinee
1126 BothOcc -> case arg of -- Used elsewhere
1127 App {} -> True -- see Note [Reboxing]
1129 other -> False -- No point; the arg is not decomposed
1130 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1131 ; return (True, mk_con_app dc (map snd args')) }
1133 -- Check if the argument is a variable that
1134 -- is in scope at the function definition site
1135 -- It's worth specialising on this if
1136 -- (a) it's used in an interesting way in the body
1137 -- (b) we know what its value is
1138 argToPat in_scope val_env (Var v) arg_occ
1139 | case arg_occ of { UnkOcc -> False; other -> True }, -- (a)
1141 = return (True, Var v)
1144 | isLocalId v = v `elemInScopeSet` in_scope
1145 && isJust (lookupVarEnv val_env v)
1146 -- Local variables have values in val_env
1147 | otherwise = isValueUnfolding (idUnfolding v)
1148 -- Imports have unfoldings
1150 -- I'm really not sure what this comment means
1151 -- And by not wild-carding we tend to get forall'd
1152 -- variables that are in soope, which in turn can
1153 -- expose the weakness in let-matching
1154 -- See Note [Matching lets] in Rules
1155 -- Check for a variable bound inside the function.
1156 -- Don't make a wild-card, because we may usefully share
1157 -- e.g. f a = let x = ... in f (x,x)
1158 -- NB: this case follows the lambda and con-app cases!!
1159 argToPat in_scope val_env (Var v) arg_occ
1160 = return (False, Var v)
1162 -- The default case: make a wild-card
1163 argToPat in_scope val_env arg arg_occ
1164 = wildCardPat (exprType arg)
1166 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1167 wildCardPat ty = do { uniq <- getUniqueUs
1168 ; let id = mkSysLocal FSLIT("sc") uniq ty
1169 ; return (False, Var id) }
1171 argsToPats :: InScopeSet -> ValueEnv
1172 -> [(CoreArg, ArgOcc)]
1173 -> UniqSM [(Bool, CoreArg)]
1174 argsToPats in_scope val_env args
1177 do_one (arg,occ) = argToPat in_scope val_env arg occ
1182 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1183 isValue env (Lit lit)
1184 = Just (ConVal (LitAlt lit) [])
1187 | Just stuff <- lookupVarEnv env v
1188 = Just stuff -- You might think we could look in the idUnfolding here
1189 -- but that doesn't take account of which branch of a
1190 -- case we are in, which is the whole point
1192 | not (isLocalId v) && isCheapUnfolding unf
1193 = isValue env (unfoldingTemplate unf)
1196 -- However we do want to consult the unfolding
1197 -- as well, for let-bound constructors!
1199 isValue env (Lam b e)
1200 | isTyVar b = isValue env e
1201 | otherwise = Just LambdaVal
1203 isValue env expr -- Maybe it's a constructor application
1204 | (Var fun, args) <- collectArgs expr
1205 = case isDataConWorkId_maybe fun of
1207 Just con | args `lengthAtLeast` dataConRepArity con
1208 -- Check saturated; might be > because the
1209 -- arity excludes type args
1210 -> Just (ConVal (DataAlt con) args)
1212 other | valArgCount args < idArity fun
1213 -- Under-applied function
1214 -> Just LambdaVal -- Partial application
1218 isValue env expr = Nothing
1220 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1221 mk_con_app (LitAlt lit) [] = Lit lit
1222 mk_con_app (DataAlt con) args = mkConApp con args
1223 mk_con_app other args = panic "SpecConstr.mk_con_app"
1225 samePat :: CallPat -> CallPat -> Bool
1226 samePat (vs1, as1) (vs2, as2)
1229 same (Var v1) (Var v2)
1230 | v1 `elem` vs1 = v2 `elem` vs2
1231 | v2 `elem` vs2 = False
1232 | otherwise = v1 == v2
1234 same (Lit l1) (Lit l2) = l1==l2
1235 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1237 same (Type t1) (Type t2) = True -- Note [Ignore type differences]
1238 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1239 same (Cast e1 _) e2 = same e1 e2
1240 same e1 (Note _ e2) = same e1 e2
1241 same e1 (Cast e2 _) = same e1 e2
1243 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1244 False -- Let, lambda, case should not occur
1246 bad (Case {}) = True
1253 Note [Ignore type differences]
1254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1255 We do not want to generate specialisations where the call patterns
1256 differ only in their type arguments! Not only is it utterly useless,
1257 but it also means that (with polymorphic recursion) we can generate
1258 an infinite number of specialisations. Example is Data.Sequence.adjustTree,