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, tcEqExpr, 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 )
22 import Type ( tyConAppArgs, tyVarsOfTypes )
23 import Unify ( coreRefineTys )
24 import Id ( Id, idName, idType, isDataConWorkId_maybe,
25 mkUserLocal, mkSysLocal )
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 )
36 import Util ( mapAccumL, lengthAtLeast, notNull )
37 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
96 trick as above. However we don't want to do that if the boxed version
97 of n is needed (else we'd avoid the eval but pay more for re-boxing n).
98 So in this case we want that the *only* uses of n are in case statements.
103 * A self-recursive function. Ignore mutual recursion for now,
104 because it's less common, and the code is simpler for self-recursion.
108 a) At a recursive call, one or more parameters is an explicit
109 constructor application
111 That same parameter is scrutinised by a case somewhere in
112 the RHS of the function
116 b) At a recursive call, one or more parameters has an unfolding
117 that is an explicit constructor application
119 That same parameter is scrutinised by a case somewhere in
120 the RHS of the function
122 Those are the only uses of the parameter
125 There's a bit of a complication with type arguments. If the call
128 f p = ...f ((:) [a] x xs)...
130 then our specialised function look like
132 f_spec x xs = let p = (:) [a] x xs in ....as before....
134 This only makes sense if either
135 a) the type variable 'a' is in scope at the top of f, or
136 b) the type variable 'a' is an argument to f (and hence fs)
138 Actually, (a) may hold for value arguments too, in which case
139 we may not want to pass them. Supose 'x' is in scope at f's
140 defn, but xs is not. Then we'd like
142 f_spec xs = let p = (:) [a] x xs in ....as before....
144 Similarly (b) may hold too. If x is already an argument at the
145 call, no need to pass it again.
147 Finally, if 'a' is not in scope at the call site, we could abstract
148 it as we do the term variables:
150 f_spec a x xs = let p = (:) [a] x xs in ...as before...
152 So the grand plan is:
154 * abstract the call site to a constructor-only pattern
155 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
157 * Find the free variables of the abstracted pattern
159 * Pass these variables, less any that are in scope at
163 NOTICE that we only abstract over variables that are not in scope,
164 so we're in no danger of shadowing variables used in "higher up"
168 %************************************************************************
170 \subsection{Top level wrapper stuff}
172 %************************************************************************
175 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
176 specConstrProgram dflags us binds
178 showPass dflags "SpecConstr"
180 let (binds', _) = initUs us (go emptyScEnv binds)
182 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
184 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
185 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
189 go env [] = returnUs []
190 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
191 go env' binds `thenUs` \ binds' ->
192 returnUs (bind' : binds')
196 %************************************************************************
198 \subsection{Environment: goes downwards}
200 %************************************************************************
203 data ScEnv = SCE { scope :: VarEnv HowBound,
204 -- Binds all non-top-level variables in scope
209 type ConstrEnv = IdEnv ConValue
210 data ConValue = CV AltCon [CoreArg]
211 -- Variables known to be bound to a constructor
212 -- in a particular case alternative
215 instance Outputable ConValue where
216 ppr (CV con args) = ppr con <+> interpp'SP args
218 refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
219 -- The substitution is a type substitution only
220 refineConstrEnv subst env = mapVarEnv refine_con_value env
222 refine_con_value (CV con args) = CV con (map (substExpr subst) args)
224 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
226 data HowBound = RecFun -- These are the recursive functions for which
227 -- we seek interesting call patterns
229 | RecArg -- These are those functions' arguments; we are
230 -- interested to see if those arguments are scrutinised
232 | Other -- We track all others so we know what's in scope
233 -- This is used in spec_one to check what needs to be
234 -- passed as a parameter and what is in scope at the
235 -- function definition site
237 instance Outputable HowBound where
238 ppr RecFun = text "RecFun"
239 ppr RecArg = text "RecArg"
240 ppr Other = text "Other"
242 lookupScopeEnv env v = lookupVarEnv (scope env) v
244 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
245 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
250 -- we want to bind b, and perhaps scrut too, to (C x y)
251 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
252 extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
253 = extendBndrs env (case_bndr : alt_bndrs)
255 extendCaseBndrs env case_bndr scrut con@(LitAlt lit) alt_bndrs
256 = ASSERT( null alt_bndrs ) extendAlt env case_bndr scrut (CV con []) []
258 extendCaseBndrs env case_bndr scrut con@(DataAlt data_con) alt_bndrs
259 | isVanillaDataCon data_con
260 = extendAlt env case_bndr scrut (CV con vanilla_args) alt_bndrs
263 = extendAlt env1 case_bndr scrut (CV con gadt_args) alt_bndrs
265 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
266 map varToCoreExpr alt_bndrs
268 gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
269 -- This call generates some bogus warnings from substExpr,
270 -- because it's inconvenient to put all the Ids in scope
271 -- Will be fixed when we move to FC
273 (alt_tvs, _) = span isTyVar alt_bndrs
274 Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
275 subst = mkSubst in_scope tv_subst emptyVarEnv -- No Id substitition
276 in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
278 env1 | is_local = env
279 | otherwise = env { cons = refineConstrEnv subst (cons env) }
283 extendAlt :: ScEnv -> Id -> CoreExpr -> ConValue -> [Var] -> ScEnv
284 extendAlt env case_bndr scrut val alt_bndrs
286 env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
287 cons = extendVarEnv (cons env) case_bndr val }
290 Var v -> -- Bind the scrutinee in the ConstrEnv if it's a variable
291 -- Also forget if the scrutinee is a RecArg, because we're
292 -- now in the branch of a case, and we don't want to
293 -- record a non-scrutinee use of v if we have
294 -- case v of { (a,b) -> ...(f v)... }
295 SCE { scope = extendVarEnv (scope env1) v Other,
296 cons = extendVarEnv (cons env1) v val }
299 -- When we encounter a recursive function binding
301 -- we want to extend the scope env with bindings
302 -- that record that f is a RecFn and x,y are RecArgs
303 extendRecBndr env fn bndrs
304 = env { scope = scope env `extendVarEnvList`
305 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
309 %************************************************************************
311 \subsection{Usage information: flows upwards}
313 %************************************************************************
318 calls :: !(IdEnv ([Call])), -- Calls
319 -- The functions are a subset of the
320 -- RecFuns in the ScEnv
322 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
323 } -- The variables are a subset of the
324 -- RecArg in the ScEnv
326 type Call = (ConstrEnv, [CoreArg])
327 -- The arguments of the call, together with the
328 -- env giving the constructor bindings at the call site
330 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
332 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
333 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
335 combineUsages [] = nullUsage
336 combineUsages us = foldr1 combineUsage us
338 data ArgOcc = CaseScrut
342 instance Outputable ArgOcc where
343 ppr CaseScrut = ptext SLIT("case-scrut")
344 ppr OtherOcc = ptext SLIT("other-occ")
345 ppr Both = ptext SLIT("case-scrut and other")
347 combineOcc CaseScrut CaseScrut = CaseScrut
348 combineOcc OtherOcc OtherOcc = OtherOcc
349 combineOcc _ _ = Both
353 %************************************************************************
355 \subsection{The main recursive function}
357 %************************************************************************
359 The main recursive function gathers up usage information, and
360 creates specialised versions of functions.
363 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
364 -- The unique supply is needed when we invent
365 -- a new name for the specialised function and its args
367 scExpr env e@(Type t) = returnUs (nullUsage, e)
368 scExpr env e@(Lit l) = returnUs (nullUsage, e)
369 scExpr env e@(Var v) = returnUs (varUsage env v OtherOcc, e)
370 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
371 returnUs (usg, Note n e')
372 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
373 returnUs (usg, Lam b e')
375 scExpr env (Case scrut b ty alts)
376 = sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
377 mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
378 returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
379 Case scrut' b ty alts')
381 sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
382 sc_scrut e = scExpr env e
384 sc_alt (con,bs,rhs) = scExpr env1 rhs `thenUs` \ (usg,rhs') ->
385 returnUs (usg, (con,bs,rhs'))
387 env1 = extendCaseBndrs env b scrut con bs
389 scExpr env (Let bind body)
390 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
391 scExpr env' body `thenUs` \ (body_usg, body') ->
392 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
394 scExpr env e@(App _ _)
396 (fn, args) = collectArgs e
398 mapAndUnzipUs (scExpr env) (fn:args) `thenUs` \ (usgs, (fn':args')) ->
399 -- Process the function too. It's almost always a variable,
400 -- but not always. In particular, if this pass follows float-in,
401 -- which it may, we can get
402 -- (let f = ...f... in f) arg1 arg2
404 call_usg = case fn of
405 Var f | Just RecFun <- lookupScopeEnv env f
406 -> SCU { calls = unitVarEnv f [(cons env, args)],
410 returnUs (combineUsages usgs `combineUsage` call_usg, mkApps fn' args')
413 ----------------------
414 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
415 scBind env (Rec [(fn,rhs)])
417 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
418 specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
420 SCU { calls = calls, occs = occs } = usg
422 returnUs (extendBndr env fn, -- For the body of the letrec, just
423 -- extend the env with Other to record
424 -- that it's in scope; no funny RecFun business
425 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
426 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
428 (bndrs,body) = collectBinders rhs
429 val_bndrs = filter isId bndrs
430 env_fn_body = extendRecBndr env fn bndrs
433 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
434 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
436 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
437 returnUs (usg, (bndr,rhs'))
439 scBind env (NonRec bndr rhs)
440 = scExpr env rhs `thenUs` \ (usg, rhs') ->
441 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
443 ----------------------
445 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
446 occs = unitVarEnv v use }
447 | otherwise = nullUsage
451 %************************************************************************
453 \subsection{The specialiser}
455 %************************************************************************
460 -> [CoreBndr] -> CoreExpr -- Its RHS
461 -> ScUsage -- Info on usage
462 -> UniqSM ([CoreRule], -- Rules
463 [(Id,CoreExpr)]) -- Bindings
465 specialise env fn bndrs body (SCU {calls=calls, occs=occs})
466 = getUs `thenUs` \ us ->
468 all_calls = lookupVarEnv calls fn `orElse` []
470 good_calls :: [[CoreArg]]
472 | (con_env, call_args) <- all_calls,
473 call_args `lengthAtLeast` n_bndrs, -- App is saturated
474 let call = bndrs `zip` call_args,
475 any (good_arg con_env occs) call, -- At least one arg is a constr app
476 let (_, pats) = argsToPats con_env us call_args
479 mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
480 (nubBy same_call good_calls `zip` [1..])
482 n_bndrs = length bndrs
483 same_call as1 as2 = and (zipWith tcEqExpr as1 as2)
485 ---------------------
486 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
487 good_arg con_env arg_occs (bndr, arg)
488 = case is_con_app_maybe con_env arg of
489 Just _ -> bndr_usg_ok arg_occs bndr arg
492 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
493 bndr_usg_ok arg_occs bndr arg
494 = case lookupVarEnv arg_occs bndr of
495 Just CaseScrut -> True -- Used only by case scrutiny
496 Just Both -> case arg of -- Used by case and elsewhere
497 App _ _ -> True -- so the arg should be an explicit con app
499 other -> False -- Not used, or used wonkily
502 ---------------------
505 -> CoreExpr -- Rhs of the original function
507 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
509 -- spec_one creates a specialised copy of the function, together
510 -- with a rule for using it. I'm very proud of how short this
511 -- function is, considering what it does :-).
517 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
518 [c::*, v::(b,c) are presumably bound by the (...) part]
520 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
521 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
523 RULE: forall b::* c::*, -- Note, *not* forall a, x
527 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
530 spec_one env fn rhs (pats, rule_number)
531 = getUniqueUs `thenUs` \ spec_uniq ->
534 fn_loc = nameSrcLoc fn_name
535 spec_occ = mkSpecOcc (nameOccName fn_name)
536 pat_fvs = varSetElems (exprsFreeVars pats)
537 vars_to_bind = filter not_avail pat_fvs
538 not_avail v = not (v `elemVarEnv` scope env)
539 -- Put the type variables first; the type of a term
540 -- variable may mention a type variable
541 (tvs, ids) = partition isTyVar vars_to_bind
543 spec_body = mkApps rhs pats
544 body_ty = exprType spec_body
546 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
547 -- Usual w/w hack to avoid generating
548 -- a spec_rhs of unlifted type and no args
550 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
551 spec_rhs = mkLams spec_lam_args spec_body
552 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
553 rule_rhs = mkVarApps (Var spec_id) spec_call_args
554 rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
556 returnUs (rule, (spec_id, spec_rhs))
558 -- In which phase should the specialise-constructor rules be active?
559 -- Originally I made them always-active, but Manuel found that
560 -- this defeated some clever user-written rules. So Plan B
561 -- is to make them active only in Phase 0; after all, currently,
562 -- the specConstr transformation is only run after the simplifier
563 -- has reached Phase 0. In general one would want it to be
564 -- flag-controllable, but for now I'm leaving it baked in
566 specConstrActivation :: Activation
567 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
570 %************************************************************************
572 \subsection{Argument analysis}
574 %************************************************************************
576 This code deals with analysing call-site arguments to see whether
577 they are constructor applications.
580 -- argToPat takes an actual argument, and returns an abstracted
581 -- version, consisting of just the "constructor skeleton" of the
582 -- argument, with non-constructor sub-expression replaced by new
583 -- placeholder variables. For example:
584 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
586 argToPat :: ConstrEnv -> UniqSupply -> CoreArg -> (UniqSupply, CoreExpr)
587 argToPat env us (Type ty)
591 | Just (CV dc args) <- is_con_app_maybe env arg
593 (us',args') = argsToPats env us args
595 (us', mk_con_app dc args')
597 argToPat env us (Var v) -- Don't uniqify existing vars,
598 = (us, Var v) -- so that we can spot when we pass them twice
601 = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
603 (us1,us2) = splitUniqSupply us
605 argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
606 argsToPats env us args = mapAccumL (argToPat env) us args
611 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
612 is_con_app_maybe env (Var v)
614 -- You might think we could look in the idUnfolding here
615 -- but that doesn't take account of which branch of a
616 -- case we are in, which is the whole point
618 is_con_app_maybe env (Lit lit)
619 = Just (CV (LitAlt lit) [])
621 is_con_app_maybe env expr
622 = case collectArgs expr of
623 (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
624 args `lengthAtLeast` dataConRepArity con
625 -- Might be > because the arity excludes type args
626 -> Just (CV (DataAlt con) args)
630 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
631 mk_con_app (LitAlt lit) [] = Lit lit
632 mk_con_app (DataAlt con) args = mkConApp con args