2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SpecConstr]{Specialise over constructors}
11 #include "HsVersions.h"
14 import CoreLint ( showPass, endPass )
15 import CoreUtils ( exprType, mkPiTypes )
16 import CoreFVs ( exprsFreeVars )
17 import CoreSubst ( Subst, mkSubst, substExpr )
18 import CoreTidy ( tidyRules )
19 import PprCore ( pprRules )
20 import WwLib ( mkWorkerArgs )
21 import DataCon ( dataConRepArity, isVanillaDataCon, dataConTyVars )
22 import Type ( Type, tyConAppArgs, tyVarsOfTypes )
23 import Rules ( matchN )
24 import Unify ( coreRefineTys )
25 import Id ( Id, idName, idType, isDataConWorkId_maybe,
26 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
30 import Name ( nameOccName, nameSrcLoc )
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 )
37 import Util ( zipWithEqual, lengthAtLeast, notNull )
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: 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.
130 Note [Good arguments]
131 ~~~~~~~~~~~~~~~~~~~~~
134 * A self-recursive function. Ignore mutual recursion for now,
135 because it's less common, and the code is simpler for self-recursion.
139 a) At a recursive call, one or more parameters is an explicit
140 constructor application
142 That same parameter is scrutinised by a case somewhere in
143 the RHS of the function
147 b) At a recursive call, one or more parameters has an unfolding
148 that is an explicit constructor application
150 That same parameter is scrutinised by a case somewhere in
151 the RHS of the function
153 Those are the only uses of the parameter (see Note [Reboxing])
156 What to abstract over
157 ~~~~~~~~~~~~~~~~~~~~~
158 There's a bit of a complication with type arguments. If the call
161 f p = ...f ((:) [a] x xs)...
163 then our specialised function look like
165 f_spec x xs = let p = (:) [a] x xs in ....as before....
167 This only makes sense if either
168 a) the type variable 'a' is in scope at the top of f, or
169 b) the type variable 'a' is an argument to f (and hence fs)
171 Actually, (a) may hold for value arguments too, in which case
172 we may not want to pass them. Supose 'x' is in scope at f's
173 defn, but xs is not. Then we'd like
175 f_spec xs = let p = (:) [a] x xs in ....as before....
177 Similarly (b) may hold too. If x is already an argument at the
178 call, no need to pass it again.
180 Finally, if 'a' is not in scope at the call site, we could abstract
181 it as we do the term variables:
183 f_spec a x xs = let p = (:) [a] x xs in ...as before...
185 So the grand plan is:
187 * abstract the call site to a constructor-only pattern
188 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
190 * Find the free variables of the abstracted pattern
192 * Pass these variables, less any that are in scope at
193 the fn defn. But see Note [Shadowing] below.
196 NOTICE that we only abstract over variables that are not in scope,
197 so we're in no danger of shadowing variables used in "higher up"
203 In this pass we gather up usage information that may mention variables
204 that are bound between the usage site and the definition site; or (more
205 seriously) may be bound to something different at the definition site.
208 f x = letrec g y v = let x = ...
211 Since 'x' is in scope at the call site, we may make a rewrite rule that
213 RULE forall a,b. g (a,b) x = ...
214 But this rule will never match, because it's really a different 'x' at
215 the call site -- and that difference will be manifest by the time the
216 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
217 no-shadowing, so perhaps it may not be distinct?]
219 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
220 is to run deShadowBinds before running SpecConstr, but instead we run the
221 simplifier. That gives the simplest possible program for SpecConstr to
222 chew on; and it virtually guarantees no shadowing.
224 Note [Specialising for constant parameters]
225 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
226 This one is about specialising on a *constant* (but not necessarily
227 constructor) argument
229 foo :: Int -> (Int -> Int) -> Int
231 foo m f = foo (f m) (+1)
235 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
237 \ (ds_dlk :: GHC.Base.Int) ->
238 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
239 GHC.Base.I# (GHC.Prim.+# x_alG 1)
241 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
244 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
245 case ww_sme of ds_Xlw {
247 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
248 T.$wfoo ww1_Xmz lvl_rmV
253 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
254 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
256 When is this worth it? Call the constant 'lvl'
257 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
258 parameter is scrutinised anywhere in the body.
260 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
261 parameter is applied (...to enough arguments...?)
263 Also do this is if the function has RULES?
267 Note [Specialising for lambda parameters]
268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
269 foo :: Int -> (Int -> Int) -> Int
271 foo m f = foo (f m) (\n -> n-m)
273 This is subtly different from the previous one in that we get an
274 explicit lambda as the argument:
276 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
279 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
280 case ww_sm8 of ds_Xlr {
282 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
285 (\ (n_ad3 :: GHC.Base.Int) ->
286 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
287 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
293 I wonder if SpecConstr couldn't be extended to handle this? After all,
294 lambda is a sort of constructor for functions and perhaps it already
295 has most of the necessary machinery?
297 Furthermore, there's an immediate win, because you don't need to allocate the lamda
298 at the call site; and if perchance it's called in the recursive call, then you
299 may avoid allocating it altogether. Just like for constructors.
301 Looks cool, but probably rare...but it might be easy to implement.
303 -----------------------------------------------------
304 Stuff not yet handled
305 -----------------------------------------------------
307 Here are notes arising from Roman's work that I don't want to lose.
313 foo :: Int -> T Int -> Int
315 foo x t | even x = case t of { T n -> foo (x-n) t }
316 | otherwise = foo (x-1) t
318 SpecConstr does no specialisation, because the second recursive call
319 looks like a boxed use of the argument. A pity.
321 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
323 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
324 case ww_sFo of ds_Xw6 [Just L] {
326 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
327 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
329 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
330 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
331 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
337 data a :*: b = !a :*: !b
340 foo :: (Int :*: T Int) -> Int
342 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
343 | otherwise = foo ((x-1) :*: t)
345 Very similar to the previous one, except that the parameters are now in
346 a strict tuple. Before SpecConstr, we have
348 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
350 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
352 case ww_sFU of ds_Xws [Just L] {
354 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
356 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
357 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
360 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
361 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
362 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
366 We get two specialisations:
367 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
368 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
369 = Foo.$s$wfoo1 a_sFB sc_sGC ;
370 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
371 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
372 = Foo.$s$wfoo y_aFp sc_sGC ;
374 But perhaps the first one isn't good. After all, we know that tpl_B2 is
375 a T (I# x) really, because T is strict and Int has one constructor. (We can't
376 unbox the strict fields, becuase T is polymorphic!)
380 %************************************************************************
382 \subsection{Top level wrapper stuff}
384 %************************************************************************
387 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
388 specConstrProgram dflags us binds
390 showPass dflags "SpecConstr"
392 let (binds', _) = initUs us (go emptyScEnv binds)
394 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
396 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
397 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
401 go env [] = returnUs []
402 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
403 go env' binds `thenUs` \ binds' ->
404 returnUs (bind' : binds')
408 %************************************************************************
410 \subsection{Environment: goes downwards}
412 %************************************************************************
415 data ScEnv = SCE { scope :: InScopeEnv,
416 -- Binds all non-top-level variables in scope
421 type InScopeEnv = VarEnv HowBound
423 type ConstrEnv = IdEnv ConValue
424 data ConValue = CV AltCon [CoreArg]
425 -- Variables known to be bound to a constructor
426 -- in a particular case alternative
429 instance Outputable ConValue where
430 ppr (CV con args) = ppr con <+> interpp'SP args
432 refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
433 -- The substitution is a type substitution only
434 refineConstrEnv subst env = mapVarEnv refine_con_value env
436 refine_con_value (CV con args) = CV con (map (substExpr subst) args)
438 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
440 data HowBound = RecFun -- These are the recursive functions for which
441 -- we seek interesting call patterns
443 | RecArg -- These are those functions' arguments, or their sub-components;
444 -- we gather occurrence information for these
446 | Other -- We track all others so we know what's in scope
447 -- This is used in spec_one to check what needs to be
448 -- passed as a parameter and what is in scope at the
449 -- function definition site
451 instance Outputable HowBound where
452 ppr RecFun = text "RecFun"
453 ppr RecArg = text "RecArg"
454 ppr Other = text "Other"
456 lookupScopeEnv env v = lookupVarEnv (scope env) v
458 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
459 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
464 -- we want to bind b, and perhaps scrut too, to (C x y)
465 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
466 extendCaseBndrs env case_bndr scrut con alt_bndrs
469 LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])
470 DataAlt dc -> extend_data_con dc
472 cur_scope = scope env
473 env1 = env { scope = extendVarEnvList cur_scope
474 [(b,how_bound) | b <- case_bndr:alt_bndrs] }
476 -- Record RecArg for the components iff the scrutinee is RecArg
477 -- [This comment looks plain wrong to me, so I'm ignoring it
478 -- "Also forget if the scrutinee is a RecArg, because we're
479 -- now in the branch of a case, and we don't want to
480 -- record a non-scrutinee use of v if we have
481 -- case v of { (a,b) -> ...(f v)... }" ]
482 how_bound = case scrut of
483 Var v -> lookupVarEnv cur_scope v `orElse` Other
486 extend_data_con data_con
487 | isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
488 | otherwise = extendCons env2 scrut case_bndr (CV con gadt_args)
489 -- Note env2 for GADTs
492 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
493 map varToCoreExpr alt_bndrs
495 gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
496 -- This call generates some bogus warnings from substExpr,
497 -- because it's inconvenient to put all the Ids in scope
498 -- Will be fixed when we move to FC
500 (alt_tvs, _) = span isTyVar alt_bndrs
501 Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
502 subst = mkSubst in_scope tv_subst emptyVarEnv -- No Id substitition
503 in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
505 env2 | is_local = env1
506 | otherwise = env1 { cons = refineConstrEnv subst (cons env) }
509 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
510 extendCons env scrut case_bndr val
512 Var v -> env { cons = extendVarEnv cons1 v val }
513 other -> env { cons = cons1 }
515 cons1 = extendVarEnv (cons env) case_bndr val
517 -- When we encounter a recursive function binding
519 -- we want to extend the scope env with bindings
520 -- that record that f is a RecFn and x,y are RecArgs
521 extendRecBndr env fn bndrs
522 = env { scope = scope env `extendVarEnvList`
523 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
527 %************************************************************************
529 \subsection{Usage information: flows upwards}
531 %************************************************************************
536 calls :: !(IdEnv ([Call])), -- Calls
537 -- The functions are a subset of the
538 -- RecFuns in the ScEnv
540 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
541 } -- The variables are a subset of the
542 -- RecArg in the ScEnv
544 type Call = (ConstrEnv, [CoreArg])
545 -- The arguments of the call, together with the
546 -- env giving the constructor bindings at the call site
548 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
550 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
551 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
553 combineUsages [] = nullUsage
554 combineUsages us = foldr1 combineUsage us
556 lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
557 lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
558 = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
559 lookupVarEnv sc_occs bndr `orElse` NoOcc)
561 lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
562 lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
563 = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
564 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
566 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
567 | UnkOcc -- Used in some unknown way
569 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
571 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
575 An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied.
577 Functions, litersl: ScrutOcc emptyUFM
578 Data constructors: ScrutOcc subs,
580 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
581 The domain of the UniqFM is the Unique of the data constructor
583 The [ArgOcc] is the occurrences of the *pattern-bound* components
584 of the data structure. E.g.
585 data T a = forall b. MkT a b (b->a)
586 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
590 instance Outputable ArgOcc where
591 ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> parens (ppr xs)
592 ppr UnkOcc = ptext SLIT("unk-occ")
593 ppr BothOcc = ptext SLIT("both-occ")
594 ppr NoOcc = ptext SLIT("no-occ")
596 combineOcc NoOcc occ = occ
597 combineOcc occ NoOcc = occ
598 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
599 combineOcc UnkOcc UnkOcc = UnkOcc
600 combineOcc _ _ = BothOcc
602 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
603 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
605 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
606 -- Find usage of components of data con; returns [UnkOcc...] if unknown
607 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
609 conArgOccs (ScrutOcc fm) (DataAlt dc)
610 | Just pat_arg_occs <- lookupUFM fm dc
611 = tyvar_unks ++ pat_arg_occs
613 tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
616 conArgOccs other con = repeat UnkOcc
620 %************************************************************************
622 \subsection{The main recursive function}
624 %************************************************************************
626 The main recursive function gathers up usage information, and
627 creates specialised versions of functions.
630 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
631 -- The unique supply is needed when we invent
632 -- a new name for the specialised function and its args
634 scExpr env e@(Type t) = returnUs (nullUsage, e)
635 scExpr env e@(Lit l) = returnUs (nullUsage, e)
636 scExpr env e@(Var v) = returnUs (varUsage env v UnkOcc, e)
637 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
638 returnUs (usg, Note n e')
639 scExpr env (Cast e co)= scExpr env e `thenUs` \ (usg,e') ->
640 returnUs (usg, Cast e' co)
641 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
642 returnUs (usg, Lam b e')
644 scExpr env (Case scrut b ty alts)
645 = do { (alt_usgs, alt_occs, alts') <- mapAndUnzip3Us sc_alt alts
646 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
647 scrut_occ = foldr combineOcc b_occ alt_occs
648 -- The combined usage of the scrutinee is given
649 -- by scrut_occ, which is passed to scScrut, which
650 -- in turn treats a bare-variable scrutinee specially
651 ; (scrut_usg, scrut') <- scScrut env scrut scrut_occ
652 ; return (alt_usg `combineUsage` scrut_usg,
653 Case scrut' b ty alts') }
656 = do { let env1 = extendCaseBndrs env b scrut con bs
657 ; (usg,rhs') <- scExpr env1 rhs
658 ; let (usg', arg_occs) = lookupOccs usg bs
659 scrut_occ = case con of
660 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
661 other -> ScrutOcc emptyUFM
662 ; return (usg', scrut_occ, (con,bs,rhs')) }
664 scExpr env (Let bind body)
665 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
666 scExpr env' body `thenUs` \ (body_usg, body') ->
667 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
669 scExpr env e@(App _ _)
670 = do { let (fn, args) = collectArgs e
671 ; (fn_usg, fn') <- scScrut env fn (ScrutOcc emptyUFM)
672 -- Process the function too. It's almost always a variable,
673 -- but not always. In particular, if this pass follows float-in,
674 -- which it may, we can get
675 -- (let f = ...f... in f) arg1 arg2
676 -- We use scScrut to record the fact that the function is called
677 -- Perhpas we should check that it has at least one value arg,
678 -- but currently we don't bother
680 ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
681 ; let call_usg = case fn of
682 Var f | Just RecFun <- lookupScopeEnv env f
683 -> SCU { calls = unitVarEnv f [(cons env, args)],
686 ; return (combineUsages arg_usgs `combineUsage` fn_usg
687 `combineUsage` call_usg,
691 ----------------------
692 scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
693 -- Used for the scrutinee of a case,
694 -- or the function of an application
695 scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e)
696 scScrut env e occ = scExpr env e
699 ----------------------
700 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
701 scBind env (Rec [(fn,rhs)])
703 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
704 specialise env fn bndrs body' usg `thenUs` \ (rules, spec_prs) ->
705 -- Note body': the specialised copies should be based on the
706 -- optimised version of the body, in case there were
707 -- nested functions inside.
709 SCU { calls = calls, occs = occs } = usg
711 returnUs (extendBndr env fn, -- For the body of the letrec, just
712 -- extend the env with Other to record
713 -- that it's in scope; no funny RecFun business
714 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
715 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
717 (bndrs,body) = collectBinders rhs
718 val_bndrs = filter isId bndrs
719 env_fn_body = extendRecBndr env fn bndrs
722 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
723 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
725 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
726 returnUs (usg, (bndr,rhs'))
728 scBind env (NonRec bndr rhs)
729 = scExpr env rhs `thenUs` \ (usg, rhs') ->
730 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
732 ----------------------
734 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
735 occs = unitVarEnv v use }
736 | otherwise = nullUsage
740 %************************************************************************
742 \subsection{The specialiser}
744 %************************************************************************
749 -> [CoreBndr] -> CoreExpr -- Its RHS
750 -> ScUsage -- Info on usage
751 -> UniqSM ([CoreRule], -- Rules
752 [(Id,CoreExpr)]) -- Bindings
754 specialise env fn bndrs body body_usg
755 = do { let (_, bndr_occs) = lookupOccs body_usg bndrs
757 ; mb_calls <- mapM (callToPats (scope env) bndr_occs)
758 (lookupVarEnv (calls body_usg) fn `orElse` [])
760 ; let good_calls :: [([Var], [CoreArg])]
761 good_calls = catMaybes mb_calls
762 in_scope = mkInScopeSet $ unionVarSets $
763 [ exprsFreeVars pats `delVarSetList` vs
764 | (vs,pats) <- good_calls ]
765 uniq_calls = nubBy (same_call in_scope) good_calls
767 mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
768 (uniq_calls `zip` [1..]) }
770 -- Two calls are the same if they match both ways
771 same_call in_scope (vs1,as1)(vs2,as2)
772 = isJust (matchN in_scope vs1 as1 as2)
773 && isJust (matchN in_scope vs2 as2 as1)
775 callToPats :: InScopeEnv -> [ArgOcc] -> Call
776 -> UniqSM (Maybe ([Var], [CoreExpr]))
777 -- The VarSet is the variables to quantify over in the rule
778 -- The [CoreExpr] are the argument patterns for the rule
779 callToPats in_scope bndr_occs (con_env, args)
780 | length args < length bndr_occs -- Check saturated
783 = do { prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
784 ; let (good_pats, pats) = unzip prs
785 pat_fvs = varSetElems (exprsFreeVars pats)
786 qvars = filter (not . (`elemVarEnv` in_scope)) pat_fvs
787 -- Quantify over variables that are not in sccpe
788 -- See Note [Shadowing] at the top
791 then return (Just (qvars, pats))
792 else return Nothing }
794 ---------------------
797 -> CoreExpr -- Rhs of the original function
798 -> (([Var], [CoreArg]), Int)
799 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
801 -- spec_one creates a specialised copy of the function, together
802 -- with a rule for using it. I'm very proud of how short this
803 -- function is, considering what it does :-).
809 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
810 [c::*, v::(b,c) are presumably bound by the (...) part]
812 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
813 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
815 RULE: forall b::* c::*, -- Note, *not* forall a, x
819 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
822 spec_one env fn rhs ((vars_to_bind, pats), rule_number)
823 = getUniqueUs `thenUs` \ spec_uniq ->
826 fn_loc = nameSrcLoc fn_name
827 spec_occ = mkSpecOcc (nameOccName fn_name)
829 -- Put the type variables first; the type of a term
830 -- variable may mention a type variable
831 (tvs, ids) = partition isTyVar vars_to_bind
833 spec_body = mkApps rhs pats
834 body_ty = exprType spec_body
836 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
837 -- Usual w/w hack to avoid generating
838 -- a spec_rhs of unlifted type and no args
840 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
841 spec_rhs = mkLams spec_lam_args spec_body
842 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
843 rule_rhs = mkVarApps (Var spec_id) spec_call_args
844 rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
846 returnUs (rule, (spec_id, spec_rhs))
848 -- In which phase should the specialise-constructor rules be active?
849 -- Originally I made them always-active, but Manuel found that
850 -- this defeated some clever user-written rules. So Plan B
851 -- is to make them active only in Phase 0; after all, currently,
852 -- the specConstr transformation is only run after the simplifier
853 -- has reached Phase 0. In general one would want it to be
854 -- flag-controllable, but for now I'm leaving it baked in
856 specConstrActivation :: Activation
857 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
860 %************************************************************************
862 \subsection{Argument analysis}
864 %************************************************************************
866 This code deals with analysing call-site arguments to see whether
867 they are constructor applications.
871 -- argToPat takes an actual argument, and returns an abstracted
872 -- version, consisting of just the "constructor skeleton" of the
873 -- argument, with non-constructor sub-expression replaced by new
874 -- placeholder variables. For example:
875 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
877 argToPat :: InScopeEnv -- What's in scope at the fn defn site
878 -> ConstrEnv -- ConstrEnv at the call site
879 -> CoreArg -- A call arg (or component thereof)
881 -> UniqSM (Bool, CoreArg)
882 -- Returns (interesting, pat),
883 -- where pat is the pattern derived from the argument
884 -- intersting=True if the pattern is non-trivial (not a variable or type)
885 -- E.g. x:xs --> (True, x:xs)
886 -- f xs --> (False, w) where w is a fresh wildcard
887 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
888 -- \x. x+y --> (True, \x. x+y)
889 -- lvl7 --> (True, lvl7) if lvl7 is bound
890 -- somewhere further out
892 argToPat in_scope con_env arg@(Type ty) arg_occ
893 = return (False, arg)
895 argToPat in_scope con_env (Var v) arg_occ
896 | not (isLocalId v) || v `elemVarEnv` in_scope
897 = -- The recursive call passes a variable that
898 -- is in scope at the function definition site
899 -- It's worth specialising on this if
900 -- (a) it's used in an interesting way in the body
901 -- (b) we know what its value is
902 if (case arg_occ of { UnkOcc -> False; other -> True }) -- (a)
903 && isValueUnfolding (idUnfolding v) -- (b)
904 then return (True, Var v)
905 else wildCardPat (idType v)
907 argToPat in_scope con_env arg arg_occ
911 is_value_lam (Lam v e) -- Spot a value lambda, even if
912 | isId v = True -- it is inside a type lambda
913 | otherwise = is_value_lam e
914 is_value_lam other = False
916 argToPat in_scope con_env arg arg_occ
917 | Just (CV dc args) <- is_con_app_maybe con_env arg
919 ScrutOcc _ -> True -- Used only by case scrutinee
920 BothOcc -> case arg of -- Used by case scrut
921 App {} -> True -- ...and elsewhere...
923 other -> False -- No point; the arg is not decomposed
924 = do { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
925 ; return (True, mk_con_app dc (map snd args')) }
927 argToPat in_scope con_env (Var v) arg_occ
928 = -- A variable bound inside the function.
929 -- Don't make a wild-card, because we may usefully share
930 -- e.g. f a = let x = ... in f (x,x)
931 -- NB: this case follows the lambda and con-app cases!!
932 return (False, Var v)
934 -- The default case: make a wild-card
935 argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg)
937 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
938 wildCardPat ty = do { uniq <- getUniqueUs
939 ; let id = mkSysLocal FSLIT("sc") uniq ty
940 ; return (False, Var id) }
942 argsToPats :: InScopeEnv -> ConstrEnv
943 -> [(CoreArg, ArgOcc)]
944 -> UniqSM [(Bool, CoreArg)]
945 argsToPats in_scope con_env args
948 do_one (arg,occ) = argToPat in_scope con_env arg occ
953 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
954 is_con_app_maybe env (Var v)
955 = case lookupVarEnv env v of
956 Just stuff -> Just stuff
957 -- You might think we could look in the idUnfolding here
958 -- but that doesn't take account of which branch of a
959 -- case we are in, which is the whole point
961 Nothing | isCheapUnfolding unf
962 -> is_con_app_maybe env (unfoldingTemplate unf)
965 -- However we do want to consult the unfolding
966 -- as well, for let-bound constructors!
970 is_con_app_maybe env (Lit lit)
971 = Just (CV (LitAlt lit) [])
973 is_con_app_maybe env expr
974 = case collectArgs expr of
975 (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
976 args `lengthAtLeast` dataConRepArity con
977 -- Might be > because the arity excludes type args
978 -> Just (CV (DataAlt con) args)
982 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
983 mk_con_app (LitAlt lit) [] = Lit lit
984 mk_con_app (DataAlt con) args = mkConApp con args