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 Coercion ( coercionKind )
23 import Rules ( matchN )
24 import Id ( Id, idName, idType, isDataConWorkId_maybe,
25 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
29 import Name ( nameOccName, nameSrcLoc )
30 import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
31 import OccName ( mkSpecOcc )
32 import ErrUtils ( dumpIfSet_dyn )
33 import DynFlags ( DynFlags, DynFlag(..) )
34 import BasicTypes ( Activation(..) )
35 import Maybes ( orElse, catMaybes, isJust )
36 import Util ( zipWithEqual, lengthAtLeast, notNull )
37 import List ( nubBy, partition )
44 -----------------------------------------------------
46 -----------------------------------------------------
51 drop n (x:xs) = drop (n-1) xs
53 After the first time round, we could pass n unboxed. This happens in
54 numerical code too. Here's what it looks like in Core:
56 drop n xs = case xs of
61 _ -> drop (I# (n# -# 1#)) xs
63 Notice that the recursive call has an explicit constructor as argument.
64 Noticing this, we can make a specialised version of drop
66 RULE: drop (I# n#) xs ==> drop' n# xs
68 drop' n# xs = let n = I# n# in ...orig RHS...
70 Now the simplifier will apply the specialisation in the rhs of drop', giving
72 drop' n# xs = case xs of
76 _ -> drop (n# -# 1#) xs
80 We'd also like to catch cases where a parameter is carried along unchanged,
81 but evaluated each time round the loop:
83 f i n = if i>0 || i>n then i else f (i*2) n
85 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
86 In Core, by the time we've w/wd (f is strict in i) we get
88 f i# n = case i# ># 0 of
90 True -> case n of n' { I# n# ->
93 True -> f (i# *# 2#) n'
95 At the call to f, we see that the argument, n is know to be (I# n#),
96 and n is evaluated elsewhere in the body of f, so we can play the same
102 We must be careful not to allocate the same constructor twice. Consider
103 f p = (...(case p of (a,b) -> e)...p...,
104 ...let t = (r,s) in ...t...(f t)...)
105 At the recursive call to f, we can see that t is a pair. But we do NOT want
106 to make a specialised copy:
107 f' a b = let p = (a,b) in (..., ...)
108 because now t is allocated by the caller, then r and s are passed to the
109 recursive call, which allocates the (r,s) pair again.
112 (a) the argument p is used in other than a case-scrutinsation way.
113 (b) the argument to the call is not a 'fresh' tuple; you have to
114 look into its unfolding to see that it's a tuple
116 Hence the "OR" part of Note [Good arguments] below.
118 ALTERNATIVE: pass both boxed and unboxed versions. This no longer saves
119 allocation, but does perhaps save evals. In the RULE we'd have
122 f (I# x#) = f' (I# x#) x#
124 If at the call site the (I# x) was an unfolding, then we'd have to
125 rely on CSE to eliminate the duplicate allocation.... This alternative
126 doesn't look attractive enough to pursue.
129 Note [Good arguments]
130 ~~~~~~~~~~~~~~~~~~~~~
133 * A self-recursive function. Ignore mutual recursion for now,
134 because it's less common, and the code is simpler for self-recursion.
138 a) At a recursive call, one or more parameters is an explicit
139 constructor application
141 That same parameter is scrutinised by a case somewhere in
142 the RHS of the function
146 b) At a recursive call, one or more parameters has an unfolding
147 that is an explicit constructor application
149 That same parameter is scrutinised by a case somewhere in
150 the RHS of the function
152 Those are the only uses of the parameter (see Note [Reboxing])
155 What to abstract over
156 ~~~~~~~~~~~~~~~~~~~~~
157 There's a bit of a complication with type arguments. If the call
160 f p = ...f ((:) [a] x xs)...
162 then our specialised function look like
164 f_spec x xs = let p = (:) [a] x xs in ....as before....
166 This only makes sense if either
167 a) the type variable 'a' is in scope at the top of f, or
168 b) the type variable 'a' is an argument to f (and hence fs)
170 Actually, (a) may hold for value arguments too, in which case
171 we may not want to pass them. Supose 'x' is in scope at f's
172 defn, but xs is not. Then we'd like
174 f_spec xs = let p = (:) [a] x xs in ....as before....
176 Similarly (b) may hold too. If x is already an argument at the
177 call, no need to pass it again.
179 Finally, if 'a' is not in scope at the call site, we could abstract
180 it as we do the term variables:
182 f_spec a x xs = let p = (:) [a] x xs in ...as before...
184 So the grand plan is:
186 * abstract the call site to a constructor-only pattern
187 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
189 * Find the free variables of the abstracted pattern
191 * Pass these variables, less any that are in scope at
192 the fn defn. But see Note [Shadowing] below.
195 NOTICE that we only abstract over variables that are not in scope,
196 so we're in no danger of shadowing variables used in "higher up"
202 In this pass we gather up usage information that may mention variables
203 that are bound between the usage site and the definition site; or (more
204 seriously) may be bound to something different at the definition site.
207 f x = letrec g y v = let x = ...
210 Since 'x' is in scope at the call site, we may make a rewrite rule that
212 RULE forall a,b. g (a,b) x = ...
213 But this rule will never match, because it's really a different 'x' at
214 the call site -- and that difference will be manifest by the time the
215 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
216 no-shadowing, so perhaps it may not be distinct?]
218 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
219 is to run deShadowBinds before running SpecConstr, but instead we run the
220 simplifier. That gives the simplest possible program for SpecConstr to
221 chew on; and it virtually guarantees no shadowing.
223 Note [Specialising for constant parameters]
224 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
225 This one is about specialising on a *constant* (but not necessarily
226 constructor) argument
228 foo :: Int -> (Int -> Int) -> Int
230 foo m f = foo (f m) (+1)
234 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
236 \ (ds_dlk :: GHC.Base.Int) ->
237 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
238 GHC.Base.I# (GHC.Prim.+# x_alG 1)
240 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
243 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
244 case ww_sme of ds_Xlw {
246 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
247 T.$wfoo ww1_Xmz lvl_rmV
252 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
253 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
255 When is this worth it? Call the constant 'lvl'
256 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
257 parameter is scrutinised anywhere in the body.
259 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
260 parameter is applied (...to enough arguments...?)
262 Also do this is if the function has RULES?
266 Note [Specialising for lambda parameters]
267 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 foo :: Int -> (Int -> Int) -> Int
270 foo m f = foo (f m) (\n -> n-m)
272 This is subtly different from the previous one in that we get an
273 explicit lambda as the argument:
275 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
278 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
279 case ww_sm8 of ds_Xlr {
281 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
284 (\ (n_ad3 :: GHC.Base.Int) ->
285 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
286 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
292 I wonder if SpecConstr couldn't be extended to handle this? After all,
293 lambda is a sort of constructor for functions and perhaps it already
294 has most of the necessary machinery?
296 Furthermore, there's an immediate win, because you don't need to allocate the lamda
297 at the call site; and if perchance it's called in the recursive call, then you
298 may avoid allocating it altogether. Just like for constructors.
300 Looks cool, but probably rare...but it might be easy to implement.
303 Note [SpecConstr for casts]
304 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
307 data instance T Int = T Int
312 go (T n) = go (T (n-1))
314 The recursive call ends up looking like
315 go (T (I# ...) `cast` g)
316 So we want to spot the construtor application inside the cast.
317 That's why we have the Cast case in argToPat
320 -----------------------------------------------------
321 Stuff not yet handled
322 -----------------------------------------------------
324 Here are notes arising from Roman's work that I don't want to lose.
330 foo :: Int -> T Int -> Int
332 foo x t | even x = case t of { T n -> foo (x-n) t }
333 | otherwise = foo (x-1) t
335 SpecConstr does no specialisation, because the second recursive call
336 looks like a boxed use of the argument. A pity.
338 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
340 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
341 case ww_sFo of ds_Xw6 [Just L] {
343 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
344 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
346 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
347 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
348 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
354 data a :*: b = !a :*: !b
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 Very similar to the previous one, except that the parameters are now in
363 a strict tuple. Before SpecConstr, we have
365 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
367 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
369 case ww_sFU of ds_Xws [Just L] {
371 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
373 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
374 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
377 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
378 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
379 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
383 We get two specialisations:
384 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
385 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
386 = Foo.$s$wfoo1 a_sFB sc_sGC ;
387 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
388 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
389 = Foo.$s$wfoo y_aFp sc_sGC ;
391 But perhaps the first one isn't good. After all, we know that tpl_B2 is
392 a T (I# x) really, because T is strict and Int has one constructor. (We can't
393 unbox the strict fields, becuase T is polymorphic!)
397 %************************************************************************
399 \subsection{Top level wrapper stuff}
401 %************************************************************************
404 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
405 specConstrProgram dflags us binds
407 showPass dflags "SpecConstr"
409 let (binds', _) = initUs us (go emptyScEnv binds)
411 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
413 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
414 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
418 go env [] = returnUs []
419 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
420 go env' binds `thenUs` \ binds' ->
421 returnUs (bind' : binds')
425 %************************************************************************
427 \subsection{Environment: goes downwards}
429 %************************************************************************
432 data ScEnv = SCE { scope :: InScopeEnv,
433 -- Binds all non-top-level variables in scope
438 type InScopeEnv = VarEnv HowBound
440 type ConstrEnv = IdEnv ConValue
441 data ConValue = CV AltCon [CoreArg]
442 -- Variables known to be bound to a constructor
443 -- in a particular case alternative
446 instance Outputable ConValue where
447 ppr (CV con args) = ppr con <+> interpp'SP args
449 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
451 data HowBound = RecFun -- These are the recursive functions for which
452 -- we seek interesting call patterns
454 | RecArg -- These are those functions' arguments, or their sub-components;
455 -- we gather occurrence information for these
457 | Other -- We track all others so we know what's in scope
458 -- This is used in spec_one to check what needs to be
459 -- passed as a parameter and what is in scope at the
460 -- function definition site
462 instance Outputable HowBound where
463 ppr RecFun = text "RecFun"
464 ppr RecArg = text "RecArg"
465 ppr Other = text "Other"
467 lookupScopeEnv env v = lookupVarEnv (scope env) v
469 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
470 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
475 -- we want to bind b, and perhaps scrut too, to (C x y)
476 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
477 extendCaseBndrs env case_bndr scrut con alt_bndrs
480 LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])
481 DataAlt dc -> extend_data_con dc
483 cur_scope = scope env
484 env1 = env { scope = extendVarEnvList cur_scope
485 [(b,how_bound) | b <- case_bndr:alt_bndrs] }
487 -- Record RecArg for the components iff the scrutinee is RecArg
488 -- I think the only reason for this is to keep the usage envt small
489 -- so is it worth it at all?
490 -- [This comment looks plain wrong to me, so I'm ignoring it
491 -- "Also forget if the scrutinee is a RecArg, because we're
492 -- now in the branch of a case, and we don't want to
493 -- record a non-scrutinee use of v if we have
494 -- case v of { (a,b) -> ...(f v)... }" ]
495 how_bound = get_how scrut
497 get_how (Var v) = lookupVarEnv cur_scope v `orElse` Other
498 get_how (Cast e _) = get_how e
499 get_how (Note _ e) = get_how e
500 get_how other = Other
502 extend_data_con data_con =
503 extendCons env1 scrut case_bndr (CV con vanilla_args)
505 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
506 varsToCoreExprs alt_bndrs
508 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
509 extendCons env scrut case_bndr val
511 Var v -> env { cons = extendVarEnv cons1 v val }
512 other -> env { cons = cons1 }
514 cons1 = extendVarEnv (cons env) case_bndr val
516 -- When we encounter a recursive function binding
518 -- we want to extend the scope env with bindings
519 -- that record that f is a RecFn and x,y are RecArgs
520 extendRecBndr env fn bndrs
521 = env { scope = scope env `extendVarEnvList`
522 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
526 %************************************************************************
528 \subsection{Usage information: flows upwards}
530 %************************************************************************
535 calls :: !(IdEnv ([Call])), -- Calls
536 -- The functions are a subset of the
537 -- RecFuns in the ScEnv
539 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
540 } -- The variables are a subset of the
541 -- RecArg in the ScEnv
543 type Call = (ConstrEnv, [CoreArg])
544 -- The arguments of the call, together with the
545 -- env giving the constructor bindings at the call site
547 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
549 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
550 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
552 combineUsages [] = nullUsage
553 combineUsages us = foldr1 combineUsage us
555 lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
556 lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
557 = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
558 lookupVarEnv sc_occs bndr `orElse` NoOcc)
560 lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
561 lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
562 = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
563 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
565 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
566 | UnkOcc -- Used in some unknown way
568 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
570 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
574 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
575 is *only* taken apart or applied.
577 Functions, literal: 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") <> ppr xs
592 ppr UnkOcc = ptext SLIT("unk-occ")
593 ppr BothOcc = ptext SLIT("both-occ")
594 ppr NoOcc = ptext SLIT("no-occ")
596 -- Experimentally, this vresion of combineOcc makes ScrutOcc "win", so
597 -- that if the thing is scrutinised anywhere then we get to see that
598 -- in the overall result, even if it's also used in a boxed way
599 -- This might be too agressive; see Note [Reboxing]
600 combineOcc NoOcc occ = occ
601 combineOcc occ NoOcc = occ
602 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
603 combineOcc occ (ScrutOcc ys) = ScrutOcc ys
604 combineOcc (ScrutOcc xs) occ = ScrutOcc xs
605 combineOcc UnkOcc UnkOcc = UnkOcc
606 combineOcc _ _ = BothOcc
608 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
609 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
611 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
612 -- Find usage of components of data con; returns [UnkOcc...] if unknown
613 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
615 conArgOccs (ScrutOcc fm) (DataAlt dc)
616 | Just pat_arg_occs <- lookupUFM fm dc
617 = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs
619 conArgOccs other con = repeat UnkOcc
623 %************************************************************************
625 \subsection{The main recursive function}
627 %************************************************************************
629 The main recursive function gathers up usage information, and
630 creates specialised versions of functions.
633 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
634 -- The unique supply is needed when we invent
635 -- a new name for the specialised function and its args
637 scExpr env e@(Type t) = returnUs (nullUsage, e)
638 scExpr env e@(Lit l) = returnUs (nullUsage, e)
639 scExpr env e@(Var v) = returnUs (varUsage env v UnkOcc, e)
640 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
641 returnUs (usg, Note n e')
642 scExpr env (Cast e co)= scExpr env e `thenUs` \ (usg,e') ->
643 returnUs (usg, Cast e' co)
644 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
645 returnUs (usg, Lam b e')
647 scExpr env (Case scrut b ty alts)
648 = do { (alt_usgs, alt_occs, alts') <- mapAndUnzip3Us sc_alt alts
649 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
650 scrut_occ = foldr combineOcc b_occ alt_occs
651 -- The combined usage of the scrutinee is given
652 -- by scrut_occ, which is passed to scScrut, which
653 -- in turn treats a bare-variable scrutinee specially
654 ; (scrut_usg, scrut') <- scScrut env scrut scrut_occ
655 ; return (alt_usg `combineUsage` scrut_usg,
656 Case scrut' b ty alts') }
659 = do { let env1 = extendCaseBndrs env b scrut con bs
660 ; (usg,rhs') <- scExpr env1 rhs
661 ; let (usg', arg_occs) = lookupOccs usg bs
662 scrut_occ = case con of
663 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
664 other -> ScrutOcc emptyUFM
665 ; return (usg', scrut_occ, (con,bs,rhs')) }
667 scExpr env (Let bind body)
668 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
669 scExpr env' body `thenUs` \ (body_usg, body') ->
670 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
672 scExpr env e@(App _ _)
673 = do { let (fn, args) = collectArgs e
674 ; (fn_usg, fn') <- scScrut env fn (ScrutOcc emptyUFM)
675 -- Process the function too. It's almost always a variable,
676 -- but not always. In particular, if this pass follows float-in,
677 -- which it may, we can get
678 -- (let f = ...f... in f) arg1 arg2
679 -- We use scScrut to record the fact that the function is called
680 -- Perhpas we should check that it has at least one value arg,
681 -- but currently we don't bother
683 ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
684 ; let call_usg = case fn of
685 Var f | Just RecFun <- lookupScopeEnv env f
686 -> SCU { calls = unitVarEnv f [(cons env, args)],
689 ; return (combineUsages arg_usgs `combineUsage` fn_usg
690 `combineUsage` call_usg,
694 ----------------------
695 scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
696 -- Used for the scrutinee of a case,
697 -- or the function of an application.
698 -- Remember to look through casts
699 scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e)
700 scScrut env (Cast e co) occ = do { (usg, e') <- scScrut env e occ
701 ; returnUs (usg, Cast e' co) }
702 scScrut env e occ = scExpr env e
705 ----------------------
706 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
707 scBind env (Rec [(fn,rhs)])
709 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
710 specialise env fn bndrs body' usg `thenUs` \ (rules, spec_prs) ->
711 -- Note body': the specialised copies should be based on the
712 -- optimised version of the body, in case there were
713 -- nested functions inside.
715 SCU { calls = calls, occs = occs } = usg
717 returnUs (extendBndr env fn, -- For the body of the letrec, just
718 -- extend the env with Other to record
719 -- that it's in scope; no funny RecFun business
720 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
721 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
723 (bndrs,body) = collectBinders rhs
724 val_bndrs = filter isId bndrs
725 env_fn_body = extendRecBndr env fn bndrs
728 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
729 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
731 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
732 returnUs (usg, (bndr,rhs'))
734 scBind env (NonRec bndr rhs)
735 = scExpr env rhs `thenUs` \ (usg, rhs') ->
736 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
738 ----------------------
740 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
741 occs = unitVarEnv v use }
742 | otherwise = nullUsage
746 %************************************************************************
748 \subsection{The specialiser}
750 %************************************************************************
755 -> [CoreBndr] -> CoreExpr -- Its RHS
756 -> ScUsage -- Info on usage
757 -> UniqSM ([CoreRule], -- Rules
758 [(Id,CoreExpr)]) -- Bindings
760 specialise env fn bndrs body body_usg
761 = do { let (_, bndr_occs) = lookupOccs body_usg bndrs
762 all_calls = lookupVarEnv (calls body_usg) fn `orElse` []
764 ; mb_pats <- mapM (callToPats (scope env) bndr_occs) all_calls
766 ; let good_pats :: [([Var], [CoreArg])]
767 good_pats = catMaybes mb_pats
768 in_scope = mkInScopeSet $ unionVarSets $
769 [ exprsFreeVars pats `delVarSetList` vs
770 | (vs,pats) <- good_pats ]
771 uniq_pats = nubBy (same_pat in_scope) good_pats
772 ; -- pprTrace "specialise" (vcat [ppr fn <+> ppr bndrs <+> ppr bndr_occs,
773 -- text "calls" <+> ppr all_calls,
774 -- text "good pats" <+> ppr good_pats,
775 -- text "uniq pats" <+> ppr uniq_pats]) $
776 mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
777 (uniq_pats `zip` [1..]) }
779 -- Two pats are the same if they match both ways
780 same_pat in_scope (vs1,as1)(vs2,as2)
781 = isJust (matchN in_scope vs1 as1 as2)
782 && isJust (matchN in_scope vs2 as2 as1)
784 callToPats :: InScopeEnv -> [ArgOcc] -> Call
785 -> UniqSM (Maybe ([Var], [CoreExpr]))
786 -- The VarSet is the variables to quantify over in the rule
787 -- The [CoreExpr] are the argument patterns for the rule
788 callToPats in_scope bndr_occs (con_env, args)
789 | length args < length bndr_occs -- Check saturated
792 = do { prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
793 ; let (good_pats, pats) = unzip prs
794 pat_fvs = varSetElems (exprsFreeVars pats)
795 qvars = filter (not . (`elemVarEnv` in_scope)) pat_fvs
796 -- Quantify over variables that are not in sccpe
797 -- See Note [Shadowing] at the top
799 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
801 then return (Just (qvars, pats))
802 else return Nothing }
804 ---------------------
807 -> CoreExpr -- Rhs of the original function
808 -> (([Var], [CoreArg]), Int)
809 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
811 -- spec_one creates a specialised copy of the function, together
812 -- with a rule for using it. I'm very proud of how short this
813 -- function is, considering what it does :-).
819 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
820 [c::*, v::(b,c) are presumably bound by the (...) part]
822 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
823 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
825 RULE: forall b::* c::*, -- Note, *not* forall a, x
829 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
832 spec_one env fn rhs ((vars_to_bind, pats), rule_number)
833 = getUniqueUs `thenUs` \ spec_uniq ->
836 fn_loc = nameSrcLoc fn_name
837 spec_occ = mkSpecOcc (nameOccName fn_name)
839 -- Put the type variables first; the type of a term
840 -- variable may mention a type variable
841 (tvs, ids) = partition isTyVar vars_to_bind
843 spec_body = mkApps rhs pats
844 body_ty = exprType spec_body
846 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
847 -- Usual w/w hack to avoid generating
848 -- a spec_rhs of unlifted type and no args
850 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
851 spec_rhs = mkLams spec_lam_args spec_body
852 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
853 rule_rhs = mkVarApps (Var spec_id) spec_call_args
854 rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
856 returnUs (rule, (spec_id, spec_rhs))
858 -- In which phase should the specialise-constructor rules be active?
859 -- Originally I made them always-active, but Manuel found that
860 -- this defeated some clever user-written rules. So Plan B
861 -- is to make them active only in Phase 0; after all, currently,
862 -- the specConstr transformation is only run after the simplifier
863 -- has reached Phase 0. In general one would want it to be
864 -- flag-controllable, but for now I'm leaving it baked in
866 specConstrActivation :: Activation
867 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
870 %************************************************************************
872 \subsection{Argument analysis}
874 %************************************************************************
876 This code deals with analysing call-site arguments to see whether
877 they are constructor applications.
881 -- argToPat takes an actual argument, and returns an abstracted
882 -- version, consisting of just the "constructor skeleton" of the
883 -- argument, with non-constructor sub-expression replaced by new
884 -- placeholder variables. For example:
885 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
887 argToPat :: InScopeEnv -- What's in scope at the fn defn site
888 -> ConstrEnv -- ConstrEnv at the call site
889 -> CoreArg -- A call arg (or component thereof)
891 -> UniqSM (Bool, CoreArg)
892 -- Returns (interesting, pat),
893 -- where pat is the pattern derived from the argument
894 -- intersting=True if the pattern is non-trivial (not a variable or type)
895 -- E.g. x:xs --> (True, x:xs)
896 -- f xs --> (False, w) where w is a fresh wildcard
897 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
898 -- \x. x+y --> (True, \x. x+y)
899 -- lvl7 --> (True, lvl7) if lvl7 is bound
900 -- somewhere further out
902 argToPat in_scope con_env arg@(Type ty) arg_occ
903 = return (False, arg)
905 argToPat in_scope con_env (Var v) arg_occ
906 | not (isLocalId v) || v `elemVarEnv` in_scope
907 = -- The recursive call passes a variable that
908 -- is in scope at the function definition site
909 -- It's worth specialising on this if
910 -- (a) it's used in an interesting way in the body
911 -- (b) we know what its value is
912 if (case arg_occ of { UnkOcc -> False; other -> True }) -- (a)
913 && isValueUnfolding (idUnfolding v) -- (b)
914 then return (True, Var v)
915 else wildCardPat (idType v)
917 argToPat in_scope con_env (Let _ arg) arg_occ
918 = argToPat in_scope con_env arg arg_occ
919 -- Look through let expressions
920 -- e.g. f (let v = rhs in \y -> ...v...)
921 -- Here we can specialise for f (\y -> ...)
922 -- because the rule-matcher will look through the let.
924 argToPat in_scope con_env (Cast arg co) arg_occ
925 = do { (interesting, arg') <- argToPat in_scope con_env arg arg_occ
926 ; if interesting then
927 return (interesting, Cast arg' co)
929 wildCardPat (snd (coercionKind co)) }
931 argToPat in_scope con_env arg arg_occ
935 is_value_lam (Lam v e) -- Spot a value lambda, even if
936 | isId v = True -- it is inside a type lambda
937 | otherwise = is_value_lam e
938 is_value_lam other = False
940 argToPat in_scope con_env arg arg_occ
941 | Just (CV dc args) <- is_con_app_maybe con_env arg
943 ScrutOcc _ -> True -- Used only by case scrutinee
944 BothOcc -> case arg of -- Used elsewhere
945 App {} -> True -- see Note [Reboxing]
947 other -> False -- No point; the arg is not decomposed
948 = do { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
949 ; return (True, mk_con_app dc (map snd args')) }
951 argToPat in_scope con_env (Var v) arg_occ
952 = -- A variable bound inside the function.
953 -- Don't make a wild-card, because we may usefully share
954 -- e.g. f a = let x = ... in f (x,x)
955 -- NB: this case follows the lambda and con-app cases!!
956 return (False, Var v)
958 -- The default case: make a wild-card
959 argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg)
961 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
962 wildCardPat ty = do { uniq <- getUniqueUs
963 ; let id = mkSysLocal FSLIT("sc") uniq ty
964 ; return (False, Var id) }
966 argsToPats :: InScopeEnv -> ConstrEnv
967 -> [(CoreArg, ArgOcc)]
968 -> UniqSM [(Bool, CoreArg)]
969 argsToPats in_scope con_env args
972 do_one (arg,occ) = argToPat in_scope con_env arg occ
977 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
978 is_con_app_maybe env (Var v)
979 = case lookupVarEnv env v of
980 Just stuff -> Just stuff
981 -- You might think we could look in the idUnfolding here
982 -- but that doesn't take account of which branch of a
983 -- case we are in, which is the whole point
985 Nothing | isCheapUnfolding unf
986 -> is_con_app_maybe env (unfoldingTemplate unf)
989 -- However we do want to consult the unfolding
990 -- as well, for let-bound constructors!
994 is_con_app_maybe env (Lit lit)
995 = Just (CV (LitAlt lit) [])
997 is_con_app_maybe env expr
998 = case collectArgs expr of
999 (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
1000 args `lengthAtLeast` dataConRepArity con
1001 -- Might be > because the arity excludes type args
1002 -> Just (CV (DataAlt con) args)
1006 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1007 mk_con_app (LitAlt lit) [] = Lit lit
1008 mk_con_app (DataAlt con) args = mkConApp con args
1009 mk_con_app other args = panic "SpecConstr.mk_con_app"