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 CoreTidy ( tidyRules )
18 import PprCore ( pprRules )
19 import WwLib ( mkWorkerArgs )
20 import DataCon ( dataConRepArity, dataConUnivTyVars )
21 import Type ( Type, tyConAppArgs )
22 import Rules ( matchN )
23 import Id ( Id, idName, idType, isDataConWorkId_maybe,
24 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
28 import Name ( nameOccName, nameSrcLoc )
29 import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
30 import OccName ( mkSpecOcc )
31 import ErrUtils ( dumpIfSet_dyn )
32 import DynFlags ( DynFlags, DynFlag(..) )
33 import BasicTypes ( Activation(..) )
34 import Maybes ( orElse, catMaybes, isJust )
35 import Util ( zipWithEqual, lengthAtLeast, notNull )
36 import List ( nubBy, partition )
43 -----------------------------------------------------
45 -----------------------------------------------------
50 drop n (x:xs) = drop (n-1) xs
52 After the first time round, we could pass n unboxed. This happens in
53 numerical code too. Here's what it looks like in Core:
55 drop n xs = case xs of
60 _ -> drop (I# (n# -# 1#)) xs
62 Notice that the recursive call has an explicit constructor as argument.
63 Noticing this, we can make a specialised version of drop
65 RULE: drop (I# n#) xs ==> drop' n# xs
67 drop' n# xs = let n = I# n# in ...orig RHS...
69 Now the simplifier will apply the specialisation in the rhs of drop', giving
71 drop' n# xs = case xs of
75 _ -> drop (n# -# 1#) xs
79 We'd also like to catch cases where a parameter is carried along unchanged,
80 but evaluated each time round the loop:
82 f i n = if i>0 || i>n then i else f (i*2) n
84 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
85 In Core, by the time we've w/wd (f is strict in i) we get
87 f i# n = case i# ># 0 of
89 True -> case n of n' { I# n# ->
92 True -> f (i# *# 2#) n'
94 At the call to f, we see that the argument, n is know to be (I# n#),
95 and n is evaluated elsewhere in the body of f, so we can play the same
101 We must be careful not to allocate the same constructor twice. Consider
102 f p = (...(case p of (a,b) -> e)...p...,
103 ...let t = (r,s) in ...t...(f t)...)
104 At the recursive call to f, we can see that t is a pair. But we do NOT want
105 to make a specialised copy:
106 f' a b = let p = (a,b) in (..., ...)
107 because now t is allocated by the caller, then r and s are passed to the
108 recursive call, which allocates the (r,s) pair again.
111 (a) the argument p is used in other than a case-scrutinsation way.
112 (b) the argument to the call is not a 'fresh' tuple; you have to
113 look into its unfolding to see that it's a tuple
115 Hence the "OR" part of Note [Good arguments] below.
117 ALTERNATIVE: pass both boxed and unboxed versions. This no longer saves
118 allocation, but does perhaps save evals. In the RULE we'd have
121 f (I# x#) = f' (I# x#) x#
123 If at the call site the (I# x) was an unfolding, then we'd have to
124 rely on CSE to eliminate the duplicate allocation.... This alternative
125 doesn't look attractive enough to pursue.
128 Note [Good arguments]
129 ~~~~~~~~~~~~~~~~~~~~~
132 * A self-recursive function. Ignore mutual recursion for now,
133 because it's less common, and the code is simpler for self-recursion.
137 a) At a recursive call, one or more parameters is an explicit
138 constructor application
140 That same parameter is scrutinised by a case somewhere in
141 the RHS of the function
145 b) At a recursive call, one or more parameters has an unfolding
146 that is an explicit constructor application
148 That same parameter is scrutinised by a case somewhere in
149 the RHS of the function
151 Those are the only uses of the parameter (see Note [Reboxing])
154 What to abstract over
155 ~~~~~~~~~~~~~~~~~~~~~
156 There's a bit of a complication with type arguments. If the call
159 f p = ...f ((:) [a] x xs)...
161 then our specialised function look like
163 f_spec x xs = let p = (:) [a] x xs in ....as before....
165 This only makes sense if either
166 a) the type variable 'a' is in scope at the top of f, or
167 b) the type variable 'a' is an argument to f (and hence fs)
169 Actually, (a) may hold for value arguments too, in which case
170 we may not want to pass them. Supose 'x' is in scope at f's
171 defn, but xs is not. Then we'd like
173 f_spec xs = let p = (:) [a] x xs in ....as before....
175 Similarly (b) may hold too. If x is already an argument at the
176 call, no need to pass it again.
178 Finally, if 'a' is not in scope at the call site, we could abstract
179 it as we do the term variables:
181 f_spec a x xs = let p = (:) [a] x xs in ...as before...
183 So the grand plan is:
185 * abstract the call site to a constructor-only pattern
186 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
188 * Find the free variables of the abstracted pattern
190 * Pass these variables, less any that are in scope at
191 the fn defn. But see Note [Shadowing] below.
194 NOTICE that we only abstract over variables that are not in scope,
195 so we're in no danger of shadowing variables used in "higher up"
201 In this pass we gather up usage information that may mention variables
202 that are bound between the usage site and the definition site; or (more
203 seriously) may be bound to something different at the definition site.
206 f x = letrec g y v = let x = ...
209 Since 'x' is in scope at the call site, we may make a rewrite rule that
211 RULE forall a,b. g (a,b) x = ...
212 But this rule will never match, because it's really a different 'x' at
213 the call site -- and that difference will be manifest by the time the
214 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
215 no-shadowing, so perhaps it may not be distinct?]
217 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
218 is to run deShadowBinds before running SpecConstr, but instead we run the
219 simplifier. That gives the simplest possible program for SpecConstr to
220 chew on; and it virtually guarantees no shadowing.
222 Note [Specialising for constant parameters]
223 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
224 This one is about specialising on a *constant* (but not necessarily
225 constructor) argument
227 foo :: Int -> (Int -> Int) -> Int
229 foo m f = foo (f m) (+1)
233 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
235 \ (ds_dlk :: GHC.Base.Int) ->
236 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
237 GHC.Base.I# (GHC.Prim.+# x_alG 1)
239 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
242 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
243 case ww_sme of ds_Xlw {
245 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
246 T.$wfoo ww1_Xmz lvl_rmV
251 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
252 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
254 When is this worth it? Call the constant 'lvl'
255 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
256 parameter is scrutinised anywhere in the body.
258 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
259 parameter is applied (...to enough arguments...?)
261 Also do this is if the function has RULES?
265 Note [Specialising for lambda parameters]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 foo :: Int -> (Int -> Int) -> Int
269 foo m f = foo (f m) (\n -> n-m)
271 This is subtly different from the previous one in that we get an
272 explicit lambda as the argument:
274 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
277 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
278 case ww_sm8 of ds_Xlr {
280 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
283 (\ (n_ad3 :: GHC.Base.Int) ->
284 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
285 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
291 I wonder if SpecConstr couldn't be extended to handle this? After all,
292 lambda is a sort of constructor for functions and perhaps it already
293 has most of the necessary machinery?
295 Furthermore, there's an immediate win, because you don't need to allocate the lamda
296 at the call site; and if perchance it's called in the recursive call, then you
297 may avoid allocating it altogether. Just like for constructors.
299 Looks cool, but probably rare...but it might be easy to implement.
301 -----------------------------------------------------
302 Stuff not yet handled
303 -----------------------------------------------------
305 Here are notes arising from Roman's work that I don't want to lose.
311 foo :: Int -> T Int -> Int
313 foo x t | even x = case t of { T n -> foo (x-n) t }
314 | otherwise = foo (x-1) t
316 SpecConstr does no specialisation, because the second recursive call
317 looks like a boxed use of the argument. A pity.
319 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
321 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
322 case ww_sFo of ds_Xw6 [Just L] {
324 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
325 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
327 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
328 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
329 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
335 data a :*: b = !a :*: !b
338 foo :: (Int :*: T Int) -> Int
340 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
341 | otherwise = foo ((x-1) :*: t)
343 Very similar to the previous one, except that the parameters are now in
344 a strict tuple. Before SpecConstr, we have
346 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
348 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
350 case ww_sFU of ds_Xws [Just L] {
352 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
354 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
355 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
358 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
359 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
360 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
364 We get two specialisations:
365 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
366 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
367 = Foo.$s$wfoo1 a_sFB sc_sGC ;
368 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
369 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
370 = Foo.$s$wfoo y_aFp sc_sGC ;
372 But perhaps the first one isn't good. After all, we know that tpl_B2 is
373 a T (I# x) really, because T is strict and Int has one constructor. (We can't
374 unbox the strict fields, becuase T is polymorphic!)
378 %************************************************************************
380 \subsection{Top level wrapper stuff}
382 %************************************************************************
385 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
386 specConstrProgram dflags us binds
388 showPass dflags "SpecConstr"
390 let (binds', _) = initUs us (go emptyScEnv binds)
392 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
394 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
395 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
399 go env [] = returnUs []
400 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
401 go env' binds `thenUs` \ binds' ->
402 returnUs (bind' : binds')
406 %************************************************************************
408 \subsection{Environment: goes downwards}
410 %************************************************************************
413 data ScEnv = SCE { scope :: InScopeEnv,
414 -- Binds all non-top-level variables in scope
419 type InScopeEnv = VarEnv HowBound
421 type ConstrEnv = IdEnv ConValue
422 data ConValue = CV AltCon [CoreArg]
423 -- Variables known to be bound to a constructor
424 -- in a particular case alternative
427 instance Outputable ConValue where
428 ppr (CV con args) = ppr con <+> interpp'SP args
430 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
432 data HowBound = RecFun -- These are the recursive functions for which
433 -- we seek interesting call patterns
435 | RecArg -- These are those functions' arguments, or their sub-components;
436 -- we gather occurrence information for these
438 | Other -- We track all others so we know what's in scope
439 -- This is used in spec_one to check what needs to be
440 -- passed as a parameter and what is in scope at the
441 -- function definition site
443 instance Outputable HowBound where
444 ppr RecFun = text "RecFun"
445 ppr RecArg = text "RecArg"
446 ppr Other = text "Other"
448 lookupScopeEnv env v = lookupVarEnv (scope env) v
450 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
451 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
456 -- we want to bind b, and perhaps scrut too, to (C x y)
457 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
458 extendCaseBndrs env case_bndr scrut con alt_bndrs
461 LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])
462 DataAlt dc -> extend_data_con dc
464 cur_scope = scope env
465 env1 = env { scope = extendVarEnvList cur_scope
466 [(b,how_bound) | b <- case_bndr:alt_bndrs] }
468 -- Record RecArg for the components iff the scrutinee is RecArg
469 -- [This comment looks plain wrong to me, so I'm ignoring it
470 -- "Also forget if the scrutinee is a RecArg, because we're
471 -- now in the branch of a case, and we don't want to
472 -- record a non-scrutinee use of v if we have
473 -- case v of { (a,b) -> ...(f v)... }" ]
474 how_bound = case scrut of
475 Var v -> lookupVarEnv cur_scope v `orElse` Other
478 extend_data_con data_con =
479 extendCons env1 scrut case_bndr (CV con vanilla_args)
481 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
482 varsToCoreExprs alt_bndrs
484 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
485 extendCons env scrut case_bndr val
487 Var v -> env { cons = extendVarEnv cons1 v val }
488 other -> env { cons = cons1 }
490 cons1 = extendVarEnv (cons env) case_bndr val
492 -- When we encounter a recursive function binding
494 -- we want to extend the scope env with bindings
495 -- that record that f is a RecFn and x,y are RecArgs
496 extendRecBndr env fn bndrs
497 = env { scope = scope env `extendVarEnvList`
498 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
502 %************************************************************************
504 \subsection{Usage information: flows upwards}
506 %************************************************************************
511 calls :: !(IdEnv ([Call])), -- Calls
512 -- The functions are a subset of the
513 -- RecFuns in the ScEnv
515 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
516 } -- The variables are a subset of the
517 -- RecArg in the ScEnv
519 type Call = (ConstrEnv, [CoreArg])
520 -- The arguments of the call, together with the
521 -- env giving the constructor bindings at the call site
523 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
525 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
526 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
528 combineUsages [] = nullUsage
529 combineUsages us = foldr1 combineUsage us
531 lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
532 lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
533 = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
534 lookupVarEnv sc_occs bndr `orElse` NoOcc)
536 lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
537 lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
538 = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
539 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
541 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
542 | UnkOcc -- Used in some unknown way
544 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
546 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
550 An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied.
552 Functions, litersl: ScrutOcc emptyUFM
553 Data constructors: ScrutOcc subs,
555 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
556 The domain of the UniqFM is the Unique of the data constructor
558 The [ArgOcc] is the occurrences of the *pattern-bound* components
559 of the data structure. E.g.
560 data T a = forall b. MkT a b (b->a)
561 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
565 instance Outputable ArgOcc where
566 ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> parens (ppr xs)
567 ppr UnkOcc = ptext SLIT("unk-occ")
568 ppr BothOcc = ptext SLIT("both-occ")
569 ppr NoOcc = ptext SLIT("no-occ")
571 combineOcc NoOcc occ = occ
572 combineOcc occ NoOcc = occ
573 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
574 combineOcc UnkOcc UnkOcc = UnkOcc
575 combineOcc _ _ = BothOcc
577 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
578 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
580 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
581 -- Find usage of components of data con; returns [UnkOcc...] if unknown
582 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
584 conArgOccs (ScrutOcc fm) (DataAlt dc)
585 | Just pat_arg_occs <- lookupUFM fm dc
586 = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs
588 conArgOccs other con = repeat UnkOcc
592 %************************************************************************
594 \subsection{The main recursive function}
596 %************************************************************************
598 The main recursive function gathers up usage information, and
599 creates specialised versions of functions.
602 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
603 -- The unique supply is needed when we invent
604 -- a new name for the specialised function and its args
606 scExpr env e@(Type t) = returnUs (nullUsage, e)
607 scExpr env e@(Lit l) = returnUs (nullUsage, e)
608 scExpr env e@(Var v) = returnUs (varUsage env v UnkOcc, e)
609 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
610 returnUs (usg, Note n e')
611 scExpr env (Cast e co)= scExpr env e `thenUs` \ (usg,e') ->
612 returnUs (usg, Cast e' co)
613 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
614 returnUs (usg, Lam b e')
616 scExpr env (Case scrut b ty alts)
617 = do { (alt_usgs, alt_occs, alts') <- mapAndUnzip3Us sc_alt alts
618 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
619 scrut_occ = foldr combineOcc b_occ alt_occs
620 -- The combined usage of the scrutinee is given
621 -- by scrut_occ, which is passed to scScrut, which
622 -- in turn treats a bare-variable scrutinee specially
623 ; (scrut_usg, scrut') <- scScrut env scrut scrut_occ
624 ; return (alt_usg `combineUsage` scrut_usg,
625 Case scrut' b ty alts') }
628 = do { let env1 = extendCaseBndrs env b scrut con bs
629 ; (usg,rhs') <- scExpr env1 rhs
630 ; let (usg', arg_occs) = lookupOccs usg bs
631 scrut_occ = case con of
632 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
633 other -> ScrutOcc emptyUFM
634 ; return (usg', scrut_occ, (con,bs,rhs')) }
636 scExpr env (Let bind body)
637 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
638 scExpr env' body `thenUs` \ (body_usg, body') ->
639 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
641 scExpr env e@(App _ _)
642 = do { let (fn, args) = collectArgs e
643 ; (fn_usg, fn') <- scScrut env fn (ScrutOcc emptyUFM)
644 -- Process the function too. It's almost always a variable,
645 -- but not always. In particular, if this pass follows float-in,
646 -- which it may, we can get
647 -- (let f = ...f... in f) arg1 arg2
648 -- We use scScrut to record the fact that the function is called
649 -- Perhpas we should check that it has at least one value arg,
650 -- but currently we don't bother
652 ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
653 ; let call_usg = case fn of
654 Var f | Just RecFun <- lookupScopeEnv env f
655 -> SCU { calls = unitVarEnv f [(cons env, args)],
658 ; return (combineUsages arg_usgs `combineUsage` fn_usg
659 `combineUsage` call_usg,
663 ----------------------
664 scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
665 -- Used for the scrutinee of a case,
666 -- or the function of an application
667 scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e)
668 scScrut env e occ = scExpr env e
671 ----------------------
672 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
673 scBind env (Rec [(fn,rhs)])
675 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
676 specialise env fn bndrs body' usg `thenUs` \ (rules, spec_prs) ->
677 -- Note body': the specialised copies should be based on the
678 -- optimised version of the body, in case there were
679 -- nested functions inside.
681 SCU { calls = calls, occs = occs } = usg
683 returnUs (extendBndr env fn, -- For the body of the letrec, just
684 -- extend the env with Other to record
685 -- that it's in scope; no funny RecFun business
686 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
687 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
689 (bndrs,body) = collectBinders rhs
690 val_bndrs = filter isId bndrs
691 env_fn_body = extendRecBndr env fn bndrs
694 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
695 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
697 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
698 returnUs (usg, (bndr,rhs'))
700 scBind env (NonRec bndr rhs)
701 = scExpr env rhs `thenUs` \ (usg, rhs') ->
702 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
704 ----------------------
706 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
707 occs = unitVarEnv v use }
708 | otherwise = nullUsage
712 %************************************************************************
714 \subsection{The specialiser}
716 %************************************************************************
721 -> [CoreBndr] -> CoreExpr -- Its RHS
722 -> ScUsage -- Info on usage
723 -> UniqSM ([CoreRule], -- Rules
724 [(Id,CoreExpr)]) -- Bindings
726 specialise env fn bndrs body body_usg
727 = do { let (_, bndr_occs) = lookupOccs body_usg bndrs
729 ; mb_calls <- mapM (callToPats (scope env) bndr_occs)
730 (lookupVarEnv (calls body_usg) fn `orElse` [])
732 ; let good_calls :: [([Var], [CoreArg])]
733 good_calls = catMaybes mb_calls
734 in_scope = mkInScopeSet $ unionVarSets $
735 [ exprsFreeVars pats `delVarSetList` vs
736 | (vs,pats) <- good_calls ]
737 uniq_calls = nubBy (same_call in_scope) good_calls
738 ; mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
739 (uniq_calls `zip` [1..]) }
741 -- Two calls are the same if they match both ways
742 same_call in_scope (vs1,as1)(vs2,as2)
743 = isJust (matchN in_scope vs1 as1 as2)
744 && isJust (matchN in_scope vs2 as2 as1)
746 callToPats :: InScopeEnv -> [ArgOcc] -> Call
747 -> UniqSM (Maybe ([Var], [CoreExpr]))
748 -- The VarSet is the variables to quantify over in the rule
749 -- The [CoreExpr] are the argument patterns for the rule
750 callToPats in_scope bndr_occs (con_env, args)
751 | length args < length bndr_occs -- Check saturated
754 = do { prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
755 ; let (good_pats, pats) = unzip prs
756 pat_fvs = varSetElems (exprsFreeVars pats)
757 qvars = filter (not . (`elemVarEnv` in_scope)) pat_fvs
758 -- Quantify over variables that are not in sccpe
759 -- See Note [Shadowing] at the top
762 then return (Just (qvars, pats))
763 else return Nothing }
765 ---------------------
768 -> CoreExpr -- Rhs of the original function
769 -> (([Var], [CoreArg]), Int)
770 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
772 -- spec_one creates a specialised copy of the function, together
773 -- with a rule for using it. I'm very proud of how short this
774 -- function is, considering what it does :-).
780 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
781 [c::*, v::(b,c) are presumably bound by the (...) part]
783 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
784 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
786 RULE: forall b::* c::*, -- Note, *not* forall a, x
790 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
793 spec_one env fn rhs ((vars_to_bind, pats), rule_number)
794 = getUniqueUs `thenUs` \ spec_uniq ->
797 fn_loc = nameSrcLoc fn_name
798 spec_occ = mkSpecOcc (nameOccName fn_name)
800 -- Put the type variables first; the type of a term
801 -- variable may mention a type variable
802 (tvs, ids) = partition isTyVar vars_to_bind
804 spec_body = mkApps rhs pats
805 body_ty = exprType spec_body
807 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
808 -- Usual w/w hack to avoid generating
809 -- a spec_rhs of unlifted type and no args
811 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
812 spec_rhs = mkLams spec_lam_args spec_body
813 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
814 rule_rhs = mkVarApps (Var spec_id) spec_call_args
815 rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
817 returnUs (rule, (spec_id, spec_rhs))
819 -- In which phase should the specialise-constructor rules be active?
820 -- Originally I made them always-active, but Manuel found that
821 -- this defeated some clever user-written rules. So Plan B
822 -- is to make them active only in Phase 0; after all, currently,
823 -- the specConstr transformation is only run after the simplifier
824 -- has reached Phase 0. In general one would want it to be
825 -- flag-controllable, but for now I'm leaving it baked in
827 specConstrActivation :: Activation
828 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
831 %************************************************************************
833 \subsection{Argument analysis}
835 %************************************************************************
837 This code deals with analysing call-site arguments to see whether
838 they are constructor applications.
842 -- argToPat takes an actual argument, and returns an abstracted
843 -- version, consisting of just the "constructor skeleton" of the
844 -- argument, with non-constructor sub-expression replaced by new
845 -- placeholder variables. For example:
846 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
848 argToPat :: InScopeEnv -- What's in scope at the fn defn site
849 -> ConstrEnv -- ConstrEnv at the call site
850 -> CoreArg -- A call arg (or component thereof)
852 -> UniqSM (Bool, CoreArg)
853 -- Returns (interesting, pat),
854 -- where pat is the pattern derived from the argument
855 -- intersting=True if the pattern is non-trivial (not a variable or type)
856 -- E.g. x:xs --> (True, x:xs)
857 -- f xs --> (False, w) where w is a fresh wildcard
858 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
859 -- \x. x+y --> (True, \x. x+y)
860 -- lvl7 --> (True, lvl7) if lvl7 is bound
861 -- somewhere further out
863 argToPat in_scope con_env arg@(Type ty) arg_occ
864 = return (False, arg)
866 argToPat in_scope con_env (Var v) arg_occ
867 | not (isLocalId v) || v `elemVarEnv` in_scope
868 = -- The recursive call passes a variable that
869 -- is in scope at the function definition site
870 -- It's worth specialising on this if
871 -- (a) it's used in an interesting way in the body
872 -- (b) we know what its value is
873 if (case arg_occ of { UnkOcc -> False; other -> True }) -- (a)
874 && isValueUnfolding (idUnfolding v) -- (b)
875 then return (True, Var v)
876 else wildCardPat (idType v)
878 argToPat in_scope con_env (Let _ arg) arg_occ
879 = argToPat in_scope con_env arg arg_occ
880 -- Look through let expressions
881 -- e.g. f (let v = rhs in \y -> ...v...)
882 -- Here we can specialise for f (\y -> ...)
883 -- because the rule-matcher will look through the let.
885 argToPat in_scope con_env arg arg_occ
889 is_value_lam (Lam v e) -- Spot a value lambda, even if
890 | isId v = True -- it is inside a type lambda
891 | otherwise = is_value_lam e
892 is_value_lam other = False
894 argToPat in_scope con_env arg arg_occ
895 | Just (CV dc args) <- is_con_app_maybe con_env arg
897 ScrutOcc _ -> True -- Used only by case scrutinee
898 BothOcc -> case arg of -- Used by case scrut
899 App {} -> True -- ...and elsewhere...
901 other -> False -- No point; the arg is not decomposed
902 = do { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
903 ; return (True, mk_con_app dc (map snd args')) }
905 argToPat in_scope con_env (Var v) arg_occ
906 = -- A variable bound inside the function.
907 -- Don't make a wild-card, because we may usefully share
908 -- e.g. f a = let x = ... in f (x,x)
909 -- NB: this case follows the lambda and con-app cases!!
910 return (False, Var v)
912 -- The default case: make a wild-card
913 argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg)
915 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
916 wildCardPat ty = do { uniq <- getUniqueUs
917 ; let id = mkSysLocal FSLIT("sc") uniq ty
918 ; return (False, Var id) }
920 argsToPats :: InScopeEnv -> ConstrEnv
921 -> [(CoreArg, ArgOcc)]
922 -> UniqSM [(Bool, CoreArg)]
923 argsToPats in_scope con_env args
926 do_one (arg,occ) = argToPat in_scope con_env arg occ
931 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
932 is_con_app_maybe env (Var v)
933 = case lookupVarEnv env v of
934 Just stuff -> Just stuff
935 -- You might think we could look in the idUnfolding here
936 -- but that doesn't take account of which branch of a
937 -- case we are in, which is the whole point
939 Nothing | isCheapUnfolding unf
940 -> is_con_app_maybe env (unfoldingTemplate unf)
943 -- However we do want to consult the unfolding
944 -- as well, for let-bound constructors!
948 is_con_app_maybe env (Lit lit)
949 = Just (CV (LitAlt lit) [])
951 is_con_app_maybe env expr
952 = case collectArgs expr of
953 (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
954 args `lengthAtLeast` dataConRepArity con
955 -- Might be > because the arity excludes type args
956 -> Just (CV (DataAlt con) args)
960 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
961 mk_con_app (LitAlt lit) [] = Lit lit
962 mk_con_app (DataAlt con) args = mkConApp con args
963 mk_con_app other args = panic "SpecConstr.mk_con_app"