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 CoreTidy ( tidyRules )
18 import PprCore ( pprRules )
19 import WwLib ( mkWorkerArgs )
20 import DataCon ( dataConRepArity )
21 import Type ( tyConAppArgs )
22 import Id ( Id, idName, idType, isDataConWorkId_maybe,
23 mkUserLocal, mkSysLocal )
27 import Name ( nameOccName, nameSrcLoc )
28 import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
29 import OccName ( mkSpecOcc )
30 import ErrUtils ( dumpIfSet_dyn )
31 import DynFlags ( DynFlags, DynFlag(..) )
32 import BasicTypes ( Activation(..) )
33 import Maybes ( orElse )
34 import Util ( mapAccumL, lengthAtLeast, notNull )
35 import List ( nubBy, partition )
41 -----------------------------------------------------
43 -----------------------------------------------------
48 drop n (x:xs) = drop (n-1) xs
50 After the first time round, we could pass n unboxed. This happens in
51 numerical code too. Here's what it looks like in Core:
53 drop n xs = case xs of
58 _ -> drop (I# (n# -# 1#)) xs
60 Notice that the recursive call has an explicit constructor as argument.
61 Noticing this, we can make a specialised version of drop
63 RULE: drop (I# n#) xs ==> drop' n# xs
65 drop' n# xs = let n = I# n# in ...orig RHS...
67 Now the simplifier will apply the specialisation in the rhs of drop', giving
69 drop' n# xs = case xs of
73 _ -> drop (n# -# 1#) xs
77 We'd also like to catch cases where a parameter is carried along unchanged,
78 but evaluated each time round the loop:
80 f i n = if i>0 || i>n then i else f (i*2) n
82 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
83 In Core, by the time we've w/wd (f is strict in i) we get
85 f i# n = case i# ># 0 of
87 True -> case n of n' { I# n# ->
90 True -> f (i# *# 2#) n'
92 At the call to f, we see that the argument, n is know to be (I# n#),
93 and n is evaluated elsewhere in the body of f, so we can play the same
94 trick as above. However we don't want to do that if the boxed version
95 of n is needed (else we'd avoid the eval but pay more for re-boxing n).
96 So in this case we want that the *only* uses of n are in case statements.
101 * A self-recursive function. Ignore mutual recursion for now,
102 because it's less common, and the code is simpler for self-recursion.
106 a) At a recursive call, one or more parameters is an explicit
107 constructor application
109 That same parameter is scrutinised by a case somewhere in
110 the RHS of the function
114 b) At a recursive call, one or more parameters has an unfolding
115 that is an explicit constructor application
117 That same parameter is scrutinised by a case somewhere in
118 the RHS of the function
120 Those are the only uses of the parameter
123 There's a bit of a complication with type arguments. If the call
126 f p = ...f ((:) [a] x xs)...
128 then our specialised function look like
130 f_spec x xs = let p = (:) [a] x xs in ....as before....
132 This only makes sense if either
133 a) the type variable 'a' is in scope at the top of f, or
134 b) the type variable 'a' is an argument to f (and hence fs)
136 Actually, (a) may hold for value arguments too, in which case
137 we may not want to pass them. Supose 'x' is in scope at f's
138 defn, but xs is not. Then we'd like
140 f_spec xs = let p = (:) [a] x xs in ....as before....
142 Similarly (b) may hold too. If x is already an argument at the
143 call, no need to pass it again.
145 Finally, if 'a' is not in scope at the call site, we could abstract
146 it as we do the term variables:
148 f_spec a x xs = let p = (:) [a] x xs in ...as before...
150 So the grand plan is:
152 * abstract the call site to a constructor-only pattern
153 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
155 * Find the free variables of the abstracted pattern
157 * Pass these variables, less any that are in scope at
161 NOTICE that we only abstract over variables that are not in scope,
162 so we're in no danger of shadowing variables used in "higher up"
166 %************************************************************************
168 \subsection{Top level wrapper stuff}
170 %************************************************************************
173 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
174 specConstrProgram dflags us binds
176 showPass dflags "SpecConstr"
178 let (binds', _) = initUs us (go emptyScEnv binds)
180 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
182 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
183 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
187 go env [] = returnUs []
188 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
189 go env' binds `thenUs` \ binds' ->
190 returnUs (bind' : binds')
194 %************************************************************************
196 \subsection{Environment: goes downwards}
198 %************************************************************************
201 data ScEnv = SCE { scope :: VarEnv HowBound,
202 -- Binds all non-top-level variables in scope
207 type ConstrEnv = IdEnv (AltCon, [CoreArg])
208 -- Variables known to be bound to a constructor
209 -- in a particular case alternative
211 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
213 data HowBound = RecFun -- These are the recursive functions for which
214 -- we seek interesting call patterns
216 | RecArg -- These are those functions' arguments; we are
217 -- interested to see if those arguments are scrutinised
219 | Other -- We track all others so we know what's in scope
220 -- This is used in spec_one to check what needs to be
221 -- passed as a parameter and what is in scope at the
222 -- function definition site
224 instance Outputable HowBound where
225 ppr RecFun = text "RecFun"
226 ppr RecArg = text "RecArg"
227 ppr Other = text "Other"
229 lookupScopeEnv env v = lookupVarEnv (scope env) v
231 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
232 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
237 -- we want to bind b, and perhaps scrut too, to (C x y)
238 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
239 extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
240 = extendBndrs env (case_bndr : alt_bndrs)
242 extendCaseBndrs env case_bndr scrut con alt_bndrs
244 Var v -> -- Bind the scrutinee in the ConstrEnv if it's a variable
245 -- Also forget if the scrutinee is a RecArg, because we're
246 -- now in the branch of a case, and we don't want to
247 -- record a non-scrutinee use of v if we have
248 -- case v of { (a,b) -> ...(f v)... }
249 SCE { scope = extendVarEnv (scope env1) v Other,
250 cons = extendVarEnv (cons env1) v (con,args) }
254 env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
255 cons = extendVarEnv (cons env) case_bndr (con,args) }
257 args = map Type (tyConAppArgs (idType case_bndr)) ++
258 map varToCoreExpr alt_bndrs
260 -- When we encounter a recursive function binding
262 -- we want to extend the scope env with bindings
263 -- that record that f is a RecFn and x,y are RecArgs
264 extendRecBndr env fn bndrs
265 = env { scope = scope env `extendVarEnvList`
266 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
270 %************************************************************************
272 \subsection{Usage information: flows upwards}
274 %************************************************************************
279 calls :: !(IdEnv ([Call])), -- Calls
280 -- The functions are a subset of the
281 -- RecFuns in the ScEnv
283 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
284 } -- The variables are a subset of the
285 -- RecArg in the ScEnv
287 type Call = (ConstrEnv, [CoreArg])
288 -- The arguments of the call, together with the
289 -- env giving the constructor bindings at the call site
291 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
293 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
294 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
296 combineUsages [] = nullUsage
297 combineUsages us = foldr1 combineUsage us
299 data ArgOcc = CaseScrut
303 instance Outputable ArgOcc where
304 ppr CaseScrut = ptext SLIT("case-scrut")
305 ppr OtherOcc = ptext SLIT("other-occ")
306 ppr Both = ptext SLIT("case-scrut and other")
308 combineOcc CaseScrut CaseScrut = CaseScrut
309 combineOcc OtherOcc OtherOcc = OtherOcc
310 combineOcc _ _ = Both
314 %************************************************************************
316 \subsection{The main recursive function}
318 %************************************************************************
320 The main recursive function gathers up usage information, and
321 creates specialised versions of functions.
324 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
325 -- The unique supply is needed when we invent
326 -- a new name for the specialised function and its args
328 scExpr env e@(Type t) = returnUs (nullUsage, e)
329 scExpr env e@(Lit l) = returnUs (nullUsage, e)
330 scExpr env e@(Var v) = returnUs (varUsage env v OtherOcc, e)
331 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
332 returnUs (usg, Note n e')
333 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
334 returnUs (usg, Lam b e')
336 scExpr env (Case scrut b ty alts)
337 = sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
338 mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
339 returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
340 Case scrut' b ty alts')
342 sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
343 sc_scrut e = scExpr env e
345 sc_alt (con,bs,rhs) = scExpr env1 rhs `thenUs` \ (usg,rhs') ->
346 returnUs (usg, (con,bs,rhs'))
348 env1 = extendCaseBndrs env b scrut con bs
350 scExpr env (Let bind body)
351 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
352 scExpr env' body `thenUs` \ (body_usg, body') ->
353 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
355 scExpr env e@(App _ _)
357 (fn, args) = collectArgs e
359 mapAndUnzipUs (scExpr env) args `thenUs` \ (usgs, args') ->
361 arg_usg = combineUsages usgs
362 fn_usg | Var f <- fn,
363 Just RecFun <- lookupScopeEnv env f
364 = SCU { calls = unitVarEnv f [(cons env, args)],
369 returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args')
370 -- Don't bother to look inside fn;
371 -- it's almost always a variable
373 ----------------------
374 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
375 scBind env (Rec [(fn,rhs)])
377 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
379 SCU { calls = calls, occs = occs } = usg
381 specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
382 returnUs (extendBndr env fn, -- For the body of the letrec, just
383 -- extend the env with Other to record
384 -- that it's in scope; no funny RecFun business
385 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
386 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
388 (bndrs,body) = collectBinders rhs
389 val_bndrs = filter isId bndrs
390 env_fn_body = extendRecBndr env fn bndrs
393 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
394 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
396 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
397 returnUs (usg, (bndr,rhs'))
399 scBind env (NonRec bndr rhs)
400 = scExpr env rhs `thenUs` \ (usg, rhs') ->
401 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
403 ----------------------
405 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
406 occs = unitVarEnv v use }
407 | otherwise = nullUsage
411 %************************************************************************
413 \subsection{The specialiser}
415 %************************************************************************
420 -> [CoreBndr] -> CoreExpr -- Its RHS
421 -> ScUsage -- Info on usage
422 -> UniqSM ([CoreRule], -- Rules
423 [(Id,CoreExpr)]) -- Bindings
425 specialise env fn bndrs body (SCU {calls=calls, occs=occs})
426 = getUs `thenUs` \ us ->
428 all_calls = lookupVarEnv calls fn `orElse` []
430 good_calls :: [[CoreArg]]
432 | (con_env, call_args) <- all_calls,
433 call_args `lengthAtLeast` n_bndrs, -- App is saturated
434 let call = (bndrs `zip` call_args),
435 any (good_arg con_env occs) call, -- At least one arg is a constr app
436 let (_, pats) = argsToPats con_env us call_args
439 mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
440 (nubBy same_call good_calls `zip` [1..])
442 n_bndrs = length bndrs
443 same_call as1 as2 = and (zipWith tcEqExpr as1 as2)
445 ---------------------
446 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
447 good_arg con_env arg_occs (bndr, arg)
448 = case is_con_app_maybe con_env arg of
449 Just _ -> bndr_usg_ok arg_occs bndr arg
452 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
453 bndr_usg_ok arg_occs bndr arg
454 = case lookupVarEnv arg_occs bndr of
455 Just CaseScrut -> True -- Used only by case scrutiny
456 Just Both -> case arg of -- Used by case and elsewhere
457 App _ _ -> True -- so the arg should be an explicit con app
459 other -> False -- Not used, or used wonkily
462 ---------------------
465 -> CoreExpr -- Rhs of the original function
467 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
469 -- spec_one creates a specialised copy of the function, together
470 -- with a rule for using it. I'm very proud of how short this
471 -- function is, considering what it does :-).
477 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
478 [c::*, v::(b,c) are presumably bound by the (...) part]
480 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
481 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
483 RULE: forall b::* c::*, -- Note, *not* forall a, x
487 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
490 spec_one env fn rhs (pats, rule_number)
491 = getUniqueUs `thenUs` \ spec_uniq ->
494 fn_loc = nameSrcLoc fn_name
495 spec_occ = mkSpecOcc (nameOccName fn_name)
496 pat_fvs = varSetElems (exprsFreeVars pats)
497 vars_to_bind = filter not_avail pat_fvs
498 not_avail v = not (v `elemVarEnv` scope env)
499 -- Put the type variables first; the type of a term
500 -- variable may mention a type variable
501 (tvs, ids) = partition isTyVar vars_to_bind
503 spec_body = mkApps rhs pats
504 body_ty = exprType spec_body
506 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
507 -- Usual w/w hack to avoid generating
508 -- a spec_rhs of unlifted type and no args
510 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
511 spec_rhs = mkLams spec_lam_args spec_body
512 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
513 rule_rhs = mkVarApps (Var spec_id) spec_call_args
514 rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
516 returnUs (rule, (spec_id, spec_rhs))
518 -- In which phase should the specialise-constructor rules be active?
519 -- Originally I made them always-active, but Manuel found that
520 -- this defeated some clever user-written rules. So Plan B
521 -- is to make them active only in Phase 0; after all, currently,
522 -- the specConstr transformation is only run after the simplifier
523 -- has reached Phase 0. In general one would want it to be
524 -- flag-controllable, but for now I'm leaving it baked in
526 specConstrActivation :: Activation
527 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
530 %************************************************************************
532 \subsection{Argument analysis}
534 %************************************************************************
536 This code deals with analysing call-site arguments to see whether
537 they are constructor applications.
540 -- argToPat takes an actual argument, and returns an abstracted
541 -- version, consisting of just the "constructor skeleton" of the
542 -- argument, with non-constructor sub-expression replaced by new
543 -- placeholder variables. For example:
544 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
546 argToPat :: ConstrEnv -> UniqSupply -> CoreArg -> (UniqSupply, CoreExpr)
547 argToPat env us (Type ty)
551 | Just (dc,args) <- is_con_app_maybe env arg
553 (us',args') = argsToPats env us args
555 (us', mk_con_app dc args')
557 argToPat env us (Var v) -- Don't uniqify existing vars,
558 = (us, Var v) -- so that we can spot when we pass them twice
561 = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
563 (us1,us2) = splitUniqSupply us
565 argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
566 argsToPats env us args = mapAccumL (argToPat env) us args
571 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe (AltCon, [CoreExpr])
572 is_con_app_maybe env (Var v)
574 -- You might think we could look in the idUnfolding here
575 -- but that doesn't take account of which branch of a
576 -- case we are in, which is the whole point
578 is_con_app_maybe env (Lit lit)
579 = Just (LitAlt lit, [])
581 is_con_app_maybe env expr
582 = case collectArgs expr of
583 (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
584 args `lengthAtLeast` dataConRepArity con
585 -- Might be > because the arity excludes type args
586 -> Just (DataAlt con,args)
590 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
591 mk_con_app (LitAlt lit) [] = Lit lit
592 mk_con_app (DataAlt con) args = mkConApp con args