2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SpecConstr]{Specialise over constructors}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
18 #include "HsVersions.h"
23 import CoreUnfold ( couldBeSmallEnoughToInline )
24 import CoreLint ( showPass, endPass )
25 import CoreFVs ( exprsFreeVars )
26 import CoreTidy ( tidyRules )
27 import PprCore ( pprRules )
28 import WwLib ( mkWorkerArgs )
29 import DataCon ( dataConRepArity, dataConUnivTyVars )
31 import Type hiding( substTy )
32 import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
33 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
38 import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
39 import OccName ( mkSpecOcc )
40 import ErrUtils ( dumpIfSet_dyn )
41 import DynFlags ( DynFlags(..), DynFlag(..) )
42 import BasicTypes ( Activation(..) )
43 import Maybes ( orElse, catMaybes, isJust )
45 import List ( nubBy, partition )
52 -----------------------------------------------------
54 -----------------------------------------------------
59 drop n (x:xs) = drop (n-1) xs
61 After the first time round, we could pass n unboxed. This happens in
62 numerical code too. Here's what it looks like in Core:
64 drop n xs = case xs of
69 _ -> drop (I# (n# -# 1#)) xs
71 Notice that the recursive call has an explicit constructor as argument.
72 Noticing this, we can make a specialised version of drop
74 RULE: drop (I# n#) xs ==> drop' n# xs
76 drop' n# xs = let n = I# n# in ...orig RHS...
78 Now the simplifier will apply the specialisation in the rhs of drop', giving
80 drop' n# xs = case xs of
84 _ -> drop (n# -# 1#) xs
88 We'd also like to catch cases where a parameter is carried along unchanged,
89 but evaluated each time round the loop:
91 f i n = if i>0 || i>n then i else f (i*2) n
93 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
94 In Core, by the time we've w/wd (f is strict in i) we get
96 f i# n = case i# ># 0 of
98 True -> case n of n' { I# n# ->
101 True -> f (i# *# 2#) n'
103 At the call to f, we see that the argument, n is know to be (I# n#),
104 and n is evaluated elsewhere in the body of f, so we can play the same
110 We must be careful not to allocate the same constructor twice. Consider
111 f p = (...(case p of (a,b) -> e)...p...,
112 ...let t = (r,s) in ...t...(f t)...)
113 At the recursive call to f, we can see that t is a pair. But we do NOT want
114 to make a specialised copy:
115 f' a b = let p = (a,b) in (..., ...)
116 because now t is allocated by the caller, then r and s are passed to the
117 recursive call, which allocates the (r,s) pair again.
120 (a) the argument p is used in other than a case-scrutinsation way.
121 (b) the argument to the call is not a 'fresh' tuple; you have to
122 look into its unfolding to see that it's a tuple
124 Hence the "OR" part of Note [Good arguments] below.
126 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
127 allocation, but does perhaps save evals. In the RULE we'd have
130 f (I# x#) = f' (I# x#) x#
132 If at the call site the (I# x) was an unfolding, then we'd have to
133 rely on CSE to eliminate the duplicate allocation.... This alternative
134 doesn't look attractive enough to pursue.
136 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
137 the conservative reboxing story prevents many useful functions from being
138 specialised. Example:
139 foo :: Maybe Int -> Int -> Int
141 foo x@(Just m) n = foo x (n-m)
142 Here the use of 'x' will clearly not require boxing in the specialised function.
144 The strictness analyser has the same problem, in fact. Example:
146 If we pass just 'a' and 'b' to the worker, it might need to rebox the
147 pair to create (a,b). A more sophisticated analysis might figure out
148 precisely the cases in which this could happen, but the strictness
149 analyser does no such analysis; it just passes 'a' and 'b', and hopes
152 So my current choice is to make SpecConstr similarly aggressive, and
153 ignore the bad potential of reboxing.
156 Note [Good arguments]
157 ~~~~~~~~~~~~~~~~~~~~~
160 * A self-recursive function. Ignore mutual recursion for now,
161 because it's less common, and the code is simpler for self-recursion.
165 a) At a recursive call, one or more parameters is an explicit
166 constructor application
168 That same parameter is scrutinised by a case somewhere in
169 the RHS of the function
173 b) At a recursive call, one or more parameters has an unfolding
174 that is an explicit constructor application
176 That same parameter is scrutinised by a case somewhere in
177 the RHS of the function
179 Those are the only uses of the parameter (see Note [Reboxing])
182 What to abstract over
183 ~~~~~~~~~~~~~~~~~~~~~
184 There's a bit of a complication with type arguments. If the call
187 f p = ...f ((:) [a] x xs)...
189 then our specialised function look like
191 f_spec x xs = let p = (:) [a] x xs in ....as before....
193 This only makes sense if either
194 a) the type variable 'a' is in scope at the top of f, or
195 b) the type variable 'a' is an argument to f (and hence fs)
197 Actually, (a) may hold for value arguments too, in which case
198 we may not want to pass them. Supose 'x' is in scope at f's
199 defn, but xs is not. Then we'd like
201 f_spec xs = let p = (:) [a] x xs in ....as before....
203 Similarly (b) may hold too. If x is already an argument at the
204 call, no need to pass it again.
206 Finally, if 'a' is not in scope at the call site, we could abstract
207 it as we do the term variables:
209 f_spec a x xs = let p = (:) [a] x xs in ...as before...
211 So the grand plan is:
213 * abstract the call site to a constructor-only pattern
214 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
216 * Find the free variables of the abstracted pattern
218 * Pass these variables, less any that are in scope at
219 the fn defn. But see Note [Shadowing] below.
222 NOTICE that we only abstract over variables that are not in scope,
223 so we're in no danger of shadowing variables used in "higher up"
229 In this pass we gather up usage information that may mention variables
230 that are bound between the usage site and the definition site; or (more
231 seriously) may be bound to something different at the definition site.
234 f x = letrec g y v = let x = ...
237 Since 'x' is in scope at the call site, we may make a rewrite rule that
239 RULE forall a,b. g (a,b) x = ...
240 But this rule will never match, because it's really a different 'x' at
241 the call site -- and that difference will be manifest by the time the
242 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
243 no-shadowing, so perhaps it may not be distinct?]
245 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
246 is to run deShadowBinds before running SpecConstr, but instead we run the
247 simplifier. That gives the simplest possible program for SpecConstr to
248 chew on; and it virtually guarantees no shadowing.
250 Note [Specialising for constant parameters]
251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
252 This one is about specialising on a *constant* (but not necessarily
253 constructor) argument
255 foo :: Int -> (Int -> Int) -> Int
257 foo m f = foo (f m) (+1)
261 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
263 \ (ds_dlk :: GHC.Base.Int) ->
264 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
265 GHC.Base.I# (GHC.Prim.+# x_alG 1)
267 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
270 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
271 case ww_sme of ds_Xlw {
273 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
274 T.$wfoo ww1_Xmz lvl_rmV
279 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
280 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
282 When is this worth it? Call the constant 'lvl'
283 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
284 parameter is scrutinised anywhere in the body.
286 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
287 parameter is applied (...to enough arguments...?)
289 Also do this is if the function has RULES?
293 Note [Specialising for lambda parameters]
294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
295 foo :: Int -> (Int -> Int) -> Int
297 foo m f = foo (f m) (\n -> n-m)
299 This is subtly different from the previous one in that we get an
300 explicit lambda as the argument:
302 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
305 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
306 case ww_sm8 of ds_Xlr {
308 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
311 (\ (n_ad3 :: GHC.Base.Int) ->
312 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
313 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
319 I wonder if SpecConstr couldn't be extended to handle this? After all,
320 lambda is a sort of constructor for functions and perhaps it already
321 has most of the necessary machinery?
323 Furthermore, there's an immediate win, because you don't need to allocate the lamda
324 at the call site; and if perchance it's called in the recursive call, then you
325 may avoid allocating it altogether. Just like for constructors.
327 Looks cool, but probably rare...but it might be easy to implement.
330 Note [SpecConstr for casts]
331 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
334 data instance T Int = T Int
339 go (T n) = go (T (n-1))
341 The recursive call ends up looking like
342 go (T (I# ...) `cast` g)
343 So we want to spot the construtor application inside the cast.
344 That's why we have the Cast case in argToPat
347 -----------------------------------------------------
348 Stuff not yet handled
349 -----------------------------------------------------
351 Here are notes arising from Roman's work that I don't want to lose.
357 foo :: Int -> T Int -> Int
359 foo x t | even x = case t of { T n -> foo (x-n) t }
360 | otherwise = foo (x-1) t
362 SpecConstr does no specialisation, because the second recursive call
363 looks like a boxed use of the argument. A pity.
365 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
367 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
368 case ww_sFo of ds_Xw6 [Just L] {
370 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
371 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
373 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
374 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
375 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
381 data a :*: b = !a :*: !b
384 foo :: (Int :*: T Int) -> Int
386 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
387 | otherwise = foo ((x-1) :*: t)
389 Very similar to the previous one, except that the parameters are now in
390 a strict tuple. Before SpecConstr, we have
392 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
394 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
396 case ww_sFU of ds_Xws [Just L] {
398 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
400 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
401 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
404 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
405 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
406 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
410 We get two specialisations:
411 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
412 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
413 = Foo.$s$wfoo1 a_sFB sc_sGC ;
414 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
415 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
416 = Foo.$s$wfoo y_aFp sc_sGC ;
418 But perhaps the first one isn't good. After all, we know that tpl_B2 is
419 a T (I# x) really, because T is strict and Int has one constructor. (We can't
420 unbox the strict fields, becuase T is polymorphic!)
424 %************************************************************************
426 \subsection{Top level wrapper stuff}
428 %************************************************************************
431 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
432 specConstrProgram dflags us binds
434 showPass dflags "SpecConstr"
436 let (binds', _) = initUs us (go (initScEnv dflags) binds)
438 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
440 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
441 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
445 go env [] = returnUs []
446 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
447 go env' binds `thenUs` \ binds' ->
448 returnUs (bind' : binds')
452 %************************************************************************
454 \subsection{Environment: goes downwards}
456 %************************************************************************
459 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
461 sc_subst :: Subst, -- Current substitution
463 sc_how_bound :: HowBoundEnv,
464 -- Binds interesting non-top-level variables
465 -- Domain is OutVars (*after* applying the substitution)
468 -- Domain is OutIds (*after* applying the substitution)
469 -- Used even for top-level bindings (but not imported ones)
472 ---------------------
473 -- As we go, we apply a substitution (sc_subst) to the current term
474 type InExpr = CoreExpr -- *Before* applying the subst
476 type OutExpr = CoreExpr -- *After* applying the subst
480 ---------------------
481 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
483 ---------------------
484 type ValueEnv = IdEnv Value -- Domain is OutIds
485 data Value = ConVal AltCon [CoreArg] -- *Saturated* constructors
486 | LambdaVal -- Inlinable lambdas or PAPs
488 instance Outputable Value where
489 ppr (ConVal con args) = ppr con <+> interpp'SP args
490 ppr LambdaVal = ptext SLIT("<Lambda>")
492 ---------------------
494 = SCE { sc_size = specConstrThreshold dflags,
495 sc_subst = emptySubst,
496 sc_how_bound = emptyVarEnv,
497 sc_vals = emptyVarEnv }
499 data HowBound = RecFun -- These are the recursive functions for which
500 -- we seek interesting call patterns
502 | RecArg -- These are those functions' arguments, or their sub-components;
503 -- we gather occurrence information for these
505 instance Outputable HowBound where
506 ppr RecFun = text "RecFun"
507 ppr RecArg = text "RecArg"
509 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
510 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
512 scSubstId :: ScEnv -> Id -> CoreExpr
513 scSubstId env v = lookupIdSubst (sc_subst env) v
515 scSubstTy :: ScEnv -> Type -> Type
516 scSubstTy env ty = substTy (sc_subst env) ty
518 zapScSubst :: ScEnv -> ScEnv
519 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
521 extendScInScope :: ScEnv -> [Var] -> ScEnv
522 -- Bring the quantified variables into scope
523 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
525 extendScSubst :: ScEnv -> [(Var,CoreArg)] -> ScEnv
526 -- Extend the substitution
527 extendScSubst env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
529 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
530 extendHowBound env bndrs how_bound
531 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
532 [(bndr,how_bound) | bndr <- bndrs] }
534 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
535 extendBndrsWith how_bound env bndrs
536 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
538 (subst', bndrs') = substBndrs (sc_subst env) bndrs
539 hb_env' = sc_how_bound env `extendVarEnvList`
540 [(bndr,how_bound) | bndr <- bndrs']
542 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
543 extendBndrWith how_bound env bndr
544 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
546 (subst', bndr') = substBndr (sc_subst env) bndr
547 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
549 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
550 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
552 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
554 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
555 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
557 (subst', bndr') = substBndr (sc_subst env) bndr
559 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
560 extendValEnv env id Nothing = env
561 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
563 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
567 -- we want to bind b, and perhaps scrut too, to (C x y)
568 -- NB: Extends only the sc_vals part of the envt
569 extendCaseBndrs env scrut case_bndr con alt_bndrs
571 Var v -> extendValEnv env1 v cval
574 env1 = extendValEnv env case_bndr cval
577 LitAlt lit -> Just (ConVal con [])
578 DataAlt dc -> Just (ConVal con vanilla_args)
580 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
581 varsToCoreExprs alt_bndrs
585 %************************************************************************
587 \subsection{Usage information: flows upwards}
589 %************************************************************************
594 calls :: CallEnv, -- Calls
595 -- The functions are a subset of the
596 -- RecFuns in the ScEnv
598 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
599 } -- The variables are a subset of the
600 -- RecArg in the ScEnv
602 type CallEnv = IdEnv [Call]
603 type Call = (ValueEnv, [CoreArg])
604 -- The arguments of the call, together with the
605 -- env giving the constructor bindings at the call site
607 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
609 combineCalls :: CallEnv -> CallEnv -> CallEnv
610 combineCalls = plusVarEnv_C (++)
612 combineUsage u1 u2 = SCU { calls = combineCalls (calls u1) (calls u2),
613 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
615 combineUsages [] = nullUsage
616 combineUsages us = foldr1 combineUsage us
618 lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
619 lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
620 = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
621 lookupVarEnv sc_occs bndr `orElse` NoOcc)
623 lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
624 lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
625 = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
626 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
628 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
629 | UnkOcc -- Used in some unknown way
631 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
633 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
637 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
638 is *only* taken apart or applied.
640 Functions, literal: ScrutOcc emptyUFM
641 Data constructors: ScrutOcc subs,
643 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
644 The domain of the UniqFM is the Unique of the data constructor
646 The [ArgOcc] is the occurrences of the *pattern-bound* components
647 of the data structure. E.g.
648 data T a = forall b. MkT a b (b->a)
649 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
653 instance Outputable ArgOcc where
654 ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
655 ppr UnkOcc = ptext SLIT("unk-occ")
656 ppr BothOcc = ptext SLIT("both-occ")
657 ppr NoOcc = ptext SLIT("no-occ")
659 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
660 -- that if the thing is scrutinised anywhere then we get to see that
661 -- in the overall result, even if it's also used in a boxed way
662 -- This might be too agressive; see Note [Reboxing] Alternative 3
663 combineOcc NoOcc occ = occ
664 combineOcc occ NoOcc = occ
665 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
666 combineOcc occ (ScrutOcc ys) = ScrutOcc ys
667 combineOcc (ScrutOcc xs) occ = ScrutOcc xs
668 combineOcc UnkOcc UnkOcc = UnkOcc
669 combineOcc _ _ = BothOcc
671 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
672 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
674 setScrutOcc :: ScEnv -> ScUsage -> CoreExpr -> ArgOcc -> ScUsage
675 -- *Overwrite* the occurrence info for the scrutinee, if the scrutinee
676 -- is a variable, and an interesting variable
677 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
678 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
679 setScrutOcc env usg (Var v) occ
680 | Just RecArg <- lookupHowBound env v = usg { occs = extendVarEnv (occs usg) v occ }
682 setScrutOcc env usg other occ -- Catch-all
685 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
686 -- Find usage of components of data con; returns [UnkOcc...] if unknown
687 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
689 conArgOccs (ScrutOcc fm) (DataAlt dc)
690 | Just pat_arg_occs <- lookupUFM fm dc
691 = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs
693 conArgOccs other con = repeat UnkOcc
696 %************************************************************************
698 \subsection{The main recursive function}
700 %************************************************************************
702 The main recursive function gathers up usage information, and
703 creates specialised versions of functions.
706 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
707 -- The unique supply is needed when we invent
708 -- a new name for the specialised function and its args
710 scExpr env e = scExpr' env e
713 scExpr' env (Var v) = case scSubstId env v of
714 Var v' -> returnUs (varUsage env v UnkOcc, Var v')
715 e' -> scExpr (zapScSubst env) e'
717 scExpr' env e@(Type t) = returnUs (nullUsage, Type (scSubstTy env t))
718 scExpr' env e@(Lit l) = returnUs (nullUsage, e)
719 scExpr' env (Note n e) = do { (usg,e') <- scExpr env e
720 ; return (usg, Note n e') }
721 scExpr' env (Cast e co) = do { (usg, e') <- scExpr env e
722 ; return (usg, Cast e' (scSubstTy env co)) }
723 scExpr' env (Lam b e) = do { let (env', b') = extendBndr env b
724 ; (usg, e') <- scExpr env' e
725 ; return (usg, Lam b' e') }
727 scExpr' env (Case scrut b ty alts)
728 = do { (scrut_usg, scrut') <- scExpr env scrut
729 ; case isValue (sc_vals env) scrut' of
730 Just (ConVal con args) -> sc_con_app con args scrut'
731 other -> sc_vanilla scrut_usg scrut'
734 sc_con_app con args scrut' -- Known constructor; simplify
735 = do { let (_, bs, rhs) = findAlt con alts
736 alt_env' = extendScSubst env ((b,scrut') : bs `zip` trimConArgs con args)
737 ; scExpr alt_env' rhs }
739 sc_vanilla scrut_usg scrut' -- Normal case
740 = do { let (alt_env,b') = extendBndrWith RecArg env b
741 -- Record RecArg for the components
743 ; (alt_usgs, alt_occs, alts')
744 <- mapAndUnzip3Us (sc_alt alt_env scrut' b') alts
746 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
747 scrut_occ = foldr combineOcc b_occ alt_occs
748 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
749 -- The combined usage of the scrutinee is given
750 -- by scrut_occ, which is passed to scScrut, which
751 -- in turn treats a bare-variable scrutinee specially
753 ; return (alt_usg `combineUsage` scrut_usg',
754 Case scrut' b' (scSubstTy env ty) alts') }
756 sc_alt env scrut' b' (con,bs,rhs)
757 = do { let (env1, bs') = extendBndrsWith RecArg env bs
758 env2 = extendCaseBndrs env1 scrut' b' con bs'
759 ; (usg,rhs') <- scExpr env2 rhs
760 ; let (usg', arg_occs) = lookupOccs usg bs
761 scrut_occ = case con of
762 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
763 other -> ScrutOcc emptyUFM
764 ; return (usg', scrut_occ, (con,bs',rhs')) }
766 scExpr' env (Let (NonRec bndr rhs) body)
767 = do { let (body_env, bndr') = extendBndr env bndr
768 ; (rhs_usg, rhs_info@(_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
770 ; if null args' || isEmptyVarEnv (calls rhs_usg) then do
772 let rhs' = mkLams args' rhs_body'
773 body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
774 -- Record if the RHS is a value
775 ; (body_usg, body') <- scExpr body_env2 body
776 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
778 do { -- Join-point case
779 let body_env2 = extendHowBound body_env [bndr'] RecFun
780 -- If the RHS of this 'let' contains calls
781 -- to recursive functions that we're trying
782 -- to specialise, then treat this let too
783 -- as one to specialise
784 ; (body_usg, body') <- scExpr body_env2 body
786 ; (spec_usg, _, specs) <- specialise env (calls body_usg) ([], rhs_info)
788 ; return (body_usg { calls = calls body_usg `delVarEnv` bndr' }
789 `combineUsage` rhs_usg `combineUsage` spec_usg,
790 mkLets [NonRec b r | (b,r) <- addRules rhs_info specs] body')
793 scExpr' env (Let (Rec prs) body)
794 = do { (env', bind_usg, bind') <- scBind env (Rec prs)
795 ; (body_usg, body') <- scExpr env' body
796 ; return (bind_usg `combineUsage` body_usg, Let bind' body') }
798 scExpr' env e@(App _ _)
799 = do { let (fn, args) = collectArgs e
800 ; (fn_usg, fn') <- scExpr env fn
801 -- Process the function too. It's almost always a variable,
802 -- but not always. In particular, if this pass follows float-in,
803 -- which it may, we can get
804 -- (let f = ...f... in f) arg1 arg2
805 -- Also the substitution may replace a variable by a non-variable
807 ; let fn_usg' = setScrutOcc env fn_usg fn' (ScrutOcc emptyUFM)
808 -- We use setScrutOcc to record the fact that the function is called
809 -- Perhaps we should check that it has at least one value arg,
810 -- but currently we don't bother
812 ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
813 ; let call_usg = case fn' of
814 Var f | Just RecFun <- lookupHowBound env f
815 , not (null args) -- Not a proper call!
816 -> SCU { calls = unitVarEnv f [(sc_vals env, args')],
819 ; return (combineUsages arg_usgs `combineUsage` fn_usg'
820 `combineUsage` call_usg,
824 ----------------------
825 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
827 | Just threshold <- sc_size env
828 , not (all (couldBeSmallEnoughToInline threshold) rhss)
830 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
831 ; (rhs_usgs, rhss') <- mapAndUnzipUs (scExpr rhs_env) rhss
832 ; return (rhs_env, combineUsages rhs_usgs, Rec (bndrs' `zip` rhss')) }
833 | otherwise -- Do specialisation
834 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
835 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
837 ; (rhs_usgs, rhs_infos) <- mapAndUnzipUs (scRecRhs rhs_env2) (bndrs' `zip` rhss)
838 ; let rhs_usg = combineUsages rhs_usgs
840 ; (spec_usg, specs) <- spec_loop rhs_env2 (calls rhs_usg)
841 (repeat [] `zip` rhs_infos)
843 ; let all_usg = rhs_usg `combineUsage` spec_usg
845 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
846 all_usg { calls = calls rhs_usg `delVarEnvList` bndrs' },
847 Rec (concat (zipWith addRules rhs_infos specs))) }
849 (bndrs,rhss) = unzip prs
853 -> [([CallPat], RhsInfo)] -- One per binder
854 -> UniqSM (ScUsage, [[SpecInfo]]) -- One list per binder
855 spec_loop env all_calls rhs_stuff
856 = do { (spec_usg_s, new_pats_s, specs) <- mapAndUnzip3Us (specialise env all_calls) rhs_stuff
857 ; let spec_usg = combineUsages spec_usg_s
858 ; if all null new_pats_s then
859 return (spec_usg, specs) else do
860 { (spec_usg1, specs1) <- spec_loop env (calls spec_usg)
861 (zipWith add_pats new_pats_s rhs_stuff)
862 ; return (spec_usg `combineUsage` spec_usg1, zipWith (++) specs specs1) } }
864 add_pats :: [CallPat] -> ([CallPat], RhsInfo) -> ([CallPat], RhsInfo)
865 add_pats new_pats (done_pats, rhs_info) = (done_pats ++ new_pats, rhs_info)
867 scBind env (NonRec bndr rhs)
868 = do { (usg, rhs') <- scExpr env rhs
869 ; let (env1, bndr') = extendBndr env bndr
870 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
871 ; return (env2, usg, NonRec bndr' rhs') }
873 ----------------------
874 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
875 scRecRhs env (bndr,rhs)
876 = do { let (arg_bndrs,body) = collectBinders rhs
877 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
878 ; (body_usg, body') <- scExpr body_env body
879 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
880 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
882 -- The arg_occs says how the visible,
883 -- lambda-bound binders of the RHS are used
884 -- (including the TyVar binders)
885 -- Two pats are the same if they match both ways
887 ----------------------
888 addRules :: RhsInfo -> [SpecInfo] -> [(Id,CoreExpr)]
889 addRules (fn, args, body, _) specs
890 = [(id,rhs) | (_,id,rhs) <- specs] ++
891 [(fn `addIdSpecialisations` rules, mkLams args body)]
893 rules = [r | (r,_,_) <- specs]
895 ----------------------
897 | Just RecArg <- lookupHowBound env v = SCU { calls = emptyVarEnv,
898 occs = unitVarEnv v use }
899 | otherwise = nullUsage
903 %************************************************************************
905 The specialiser itself
907 %************************************************************************
910 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
911 -- Info about the *original* RHS of a binding we are specialising
912 -- Original binding f = \xs.body
913 -- Plus info about usage of arguments
915 type SpecInfo = (CoreRule, OutId, OutExpr)
916 -- One specialisation: Rule plus definition
921 -> CallEnv -- Info on calls
922 -> ([CallPat], RhsInfo) -- Original RHS plus patterns dealt with
923 -> UniqSM (ScUsage, [CallPat], [SpecInfo]) -- Specialised calls
925 -- Note: the rhs here is the optimised version of the original rhs
926 -- So when we make a specialised copy of the RHS, we're starting
927 -- from an RHS whose nested functions have been optimised already.
929 specialise env bind_calls (done_pats, (fn, arg_bndrs, body, arg_occs))
930 | notNull arg_bndrs, -- Only specialise functions
931 Just all_calls <- lookupVarEnv bind_calls fn
932 = do { pats <- callsToPats env done_pats arg_occs all_calls
933 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
934 -- text "calls" <+> ppr all_calls,
935 -- text "good pats" <+> ppr pats]) $
938 ; (spec_usgs, specs) <- mapAndUnzipUs (spec_one env fn arg_bndrs body)
939 (pats `zip` [length done_pats..])
941 ; return (combineUsages spec_usgs, pats, specs) }
943 = return (nullUsage, [], []) -- The boring case
946 ---------------------
949 -> [Var] -- Lambda-binders of RHS; should match patterns
950 -> CoreExpr -- Body of the original function
951 -> (([Var], [CoreArg]), Int)
952 -> UniqSM (ScUsage, SpecInfo) -- Rule and binding
954 -- spec_one creates a specialised copy of the function, together
955 -- with a rule for using it. I'm very proud of how short this
956 -- function is, considering what it does :-).
962 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
963 [c::*, v::(b,c) are presumably bound by the (...) part]
965 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
966 (...entire body of f...) [b -> (b,c),
967 y -> ((:) (a,(b,c)) (x,v) hw)]
969 RULE: forall b::* c::*, -- Note, *not* forall a, x
973 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
976 spec_one env fn arg_bndrs body ((qvars, pats), rule_number)
977 = do { -- Specialise the body
978 let spec_env = extendScSubst (extendScInScope env qvars)
979 (arg_bndrs `zip` pats)
980 ; (spec_usg, spec_body) <- scExpr spec_env body
982 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
983 -- text "calls" <+> (ppr (calls spec_usg))])
986 -- And build the results
987 ; spec_uniq <- getUniqueUs
988 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
989 -- Usual w/w hack to avoid generating
990 -- a spec_rhs of unlifted type and no args
993 fn_loc = nameSrcSpan fn_name
994 spec_occ = mkSpecOcc (nameOccName fn_name)
995 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
996 spec_rhs = mkLams spec_lam_args spec_body
997 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
998 body_ty = exprType spec_body
999 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1000 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1001 ; return (spec_usg, (rule, spec_id, spec_rhs)) }
1003 -- In which phase should the specialise-constructor rules be active?
1004 -- Originally I made them always-active, but Manuel found that
1005 -- this defeated some clever user-written rules. So Plan B
1006 -- is to make them active only in Phase 0; after all, currently,
1007 -- the specConstr transformation is only run after the simplifier
1008 -- has reached Phase 0. In general one would want it to be
1009 -- flag-controllable, but for now I'm leaving it baked in
1011 specConstrActivation :: Activation
1012 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1015 %************************************************************************
1017 \subsection{Argument analysis}
1019 %************************************************************************
1021 This code deals with analysing call-site arguments to see whether
1022 they are constructor applications.
1026 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1029 callsToPats :: ScEnv -> [CallPat] -> [ArgOcc] -> [Call] -> UniqSM [CallPat]
1030 -- Result has no duplicate patterns,
1031 -- nor ones mentioned in done_pats
1032 callsToPats env done_pats bndr_occs calls
1033 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1035 ; let good_pats :: [([Var], [CoreArg])]
1036 good_pats = catMaybes mb_pats
1037 is_done p = any (samePat p) done_pats
1039 ; return (filterOut is_done (nubBy samePat good_pats)) }
1041 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1042 -- The [Var] is the variables to quantify over in the rule
1043 -- Type variables come first, since they may scope
1044 -- over the following term variables
1045 -- The [CoreExpr] are the argument patterns for the rule
1046 callToPats env bndr_occs (con_env, args)
1047 | length args < length bndr_occs -- Check saturated
1050 = do { let in_scope = substInScope (sc_subst env)
1051 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1052 ; let (good_pats, pats) = unzip prs
1053 pat_fvs = varSetElems (exprsFreeVars pats)
1054 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1055 -- Quantify over variables that are not in sccpe
1057 -- See Note [Shadowing] at the top
1059 (tvs, ids) = partition isTyVar qvars
1061 -- Put the type variables first; the type of a term
1062 -- variable may mention a type variable
1064 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1066 then return (Just (qvars', pats))
1067 else return Nothing }
1069 -- argToPat takes an actual argument, and returns an abstracted
1070 -- version, consisting of just the "constructor skeleton" of the
1071 -- argument, with non-constructor sub-expression replaced by new
1072 -- placeholder variables. For example:
1073 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1075 argToPat :: InScopeSet -- What's in scope at the fn defn site
1076 -> ValueEnv -- ValueEnv at the call site
1077 -> CoreArg -- A call arg (or component thereof)
1079 -> UniqSM (Bool, CoreArg)
1080 -- Returns (interesting, pat),
1081 -- where pat is the pattern derived from the argument
1082 -- intersting=True if the pattern is non-trivial (not a variable or type)
1083 -- E.g. x:xs --> (True, x:xs)
1084 -- f xs --> (False, w) where w is a fresh wildcard
1085 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1086 -- \x. x+y --> (True, \x. x+y)
1087 -- lvl7 --> (True, lvl7) if lvl7 is bound
1088 -- somewhere further out
1090 argToPat in_scope val_env arg@(Type ty) arg_occ
1091 = return (False, arg)
1093 argToPat in_scope val_env (Note n arg) arg_occ
1094 = argToPat in_scope val_env arg arg_occ
1095 -- Note [Notes in call patterns]
1096 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1097 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1098 -- Perhaps we should not ignore profiling notes, but I'm going to
1099 -- ride roughshod over them all for now.
1100 --- See Note [Notes in RULE matching] in Rules
1102 argToPat in_scope val_env (Let _ arg) arg_occ
1103 = argToPat in_scope val_env arg arg_occ
1104 -- Look through let expressions
1105 -- e.g. f (let v = rhs in \y -> ...v...)
1106 -- Here we can specialise for f (\y -> ...)
1107 -- because the rule-matcher will look through the let.
1109 argToPat in_scope val_env (Cast arg co) arg_occ
1110 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1111 ; let (ty1,ty2) = coercionKind co
1112 ; if not interesting then
1115 { -- Make a wild-card pattern for the coercion
1117 ; let co_name = mkSysTvName uniq FSLIT("sg")
1118 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1119 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1121 {- Disabling lambda specialisation for now
1122 It's fragile, and the spec_loop can be infinite
1123 argToPat in_scope val_env arg arg_occ
1125 = return (True, arg)
1127 is_value_lam (Lam v e) -- Spot a value lambda, even if
1128 | isId v = True -- it is inside a type lambda
1129 | otherwise = is_value_lam e
1130 is_value_lam other = False
1133 -- Check for a constructor application
1134 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1135 argToPat in_scope val_env arg arg_occ
1136 | Just (ConVal dc args) <- isValue val_env arg
1138 ScrutOcc _ -> True -- Used only by case scrutinee
1139 BothOcc -> case arg of -- Used elsewhere
1140 App {} -> True -- see Note [Reboxing]
1142 other -> False -- No point; the arg is not decomposed
1143 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1144 ; return (True, mk_con_app dc (map snd args')) }
1146 -- Check if the argument is a variable that
1147 -- is in scope at the function definition site
1148 -- It's worth specialising on this if
1149 -- (a) it's used in an interesting way in the body
1150 -- (b) we know what its value is
1151 argToPat in_scope val_env (Var v) arg_occ
1152 | case arg_occ of { UnkOcc -> False; other -> True }, -- (a)
1154 = return (True, Var v)
1157 | isLocalId v = v `elemInScopeSet` in_scope
1158 && isJust (lookupVarEnv val_env v)
1159 -- Local variables have values in val_env
1160 | otherwise = isValueUnfolding (idUnfolding v)
1161 -- Imports have unfoldings
1163 -- I'm really not sure what this comment means
1164 -- And by not wild-carding we tend to get forall'd
1165 -- variables that are in soope, which in turn can
1166 -- expose the weakness in let-matching
1167 -- See Note [Matching lets] in Rules
1168 -- Check for a variable bound inside the function.
1169 -- Don't make a wild-card, because we may usefully share
1170 -- e.g. f a = let x = ... in f (x,x)
1171 -- NB: this case follows the lambda and con-app cases!!
1172 argToPat in_scope val_env (Var v) arg_occ
1173 = return (False, Var v)
1175 -- The default case: make a wild-card
1176 argToPat in_scope val_env arg arg_occ
1177 = wildCardPat (exprType arg)
1179 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1180 wildCardPat ty = do { uniq <- getUniqueUs
1181 ; let id = mkSysLocal FSLIT("sc") uniq ty
1182 ; return (False, Var id) }
1184 argsToPats :: InScopeSet -> ValueEnv
1185 -> [(CoreArg, ArgOcc)]
1186 -> UniqSM [(Bool, CoreArg)]
1187 argsToPats in_scope val_env args
1190 do_one (arg,occ) = argToPat in_scope val_env arg occ
1195 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1196 isValue env (Lit lit)
1197 = Just (ConVal (LitAlt lit) [])
1200 | Just stuff <- lookupVarEnv env v
1201 = Just stuff -- You might think we could look in the idUnfolding here
1202 -- but that doesn't take account of which branch of a
1203 -- case we are in, which is the whole point
1205 | not (isLocalId v) && isCheapUnfolding unf
1206 = isValue env (unfoldingTemplate unf)
1209 -- However we do want to consult the unfolding
1210 -- as well, for let-bound constructors!
1212 isValue env (Lam b e)
1213 | isTyVar b = isValue env e
1214 | otherwise = Just LambdaVal
1216 isValue env expr -- Maybe it's a constructor application
1217 | (Var fun, args) <- collectArgs expr
1218 = case isDataConWorkId_maybe fun of
1220 Just con | args `lengthAtLeast` dataConRepArity con
1221 -- Check saturated; might be > because the
1222 -- arity excludes type args
1223 -> Just (ConVal (DataAlt con) args)
1225 other | valArgCount args < idArity fun
1226 -- Under-applied function
1227 -> Just LambdaVal -- Partial application
1231 isValue env expr = Nothing
1233 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1234 mk_con_app (LitAlt lit) [] = Lit lit
1235 mk_con_app (DataAlt con) args = mkConApp con args
1236 mk_con_app other args = panic "SpecConstr.mk_con_app"
1238 samePat :: CallPat -> CallPat -> Bool
1239 samePat (vs1, as1) (vs2, as2)
1242 same (Var v1) (Var v2)
1243 | v1 `elem` vs1 = v2 `elem` vs2
1244 | v2 `elem` vs2 = False
1245 | otherwise = v1 == v2
1247 same (Lit l1) (Lit l2) = l1==l2
1248 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1250 same (Type t1) (Type t2) = True -- Note [Ignore type differences]
1251 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1252 same (Cast e1 _) e2 = same e1 e2
1253 same e1 (Note _ e2) = same e1 e2
1254 same e1 (Cast e2 _) = same e1 e2
1256 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1257 False -- Let, lambda, case should not occur
1258 bad (Case {}) = True
1264 Note [Ignore type differences]
1265 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1266 We do not want to generate specialisations where the call patterns
1267 differ only in their type arguments! Not only is it utterly useless,
1268 but it also means that (with polymorphic recursion) we can generate
1269 an infinite number of specialisations. Example is Data.Sequence.adjustTree,