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, eqExpr, mkPiTypes )
16 import CoreFVs ( exprsFreeVars )
17 import WwLib ( mkWorkerArgs )
18 import DataCon ( dataConRepArity )
19 import Type ( tyConAppArgs )
20 import PprCore ( pprCoreRules )
21 import Id ( Id, idName, idType, idSpecialisation,
23 mkUserLocal, mkSysLocal )
27 import Name ( nameOccName, nameSrcLoc )
28 import Rules ( addIdSpecialisations )
29 import OccName ( mkSpecOcc )
30 import ErrUtils ( dumpIfSet_dyn )
31 import CmdLineOpts ( DynFlags, DynFlag(..) )
32 import BasicTypes ( Activation(..) )
35 import Maybes ( orElse )
36 import Util ( mapAccumL, lengthAtLeast )
37 import List ( nubBy, partition )
42 -----------------------------------------------------
44 -----------------------------------------------------
49 drop n (x:xs) = drop (n-1) xs
51 After the first time round, we could pass n unboxed. This happens in
52 numerical code too. Here's what it looks like in Core:
54 drop n xs = case xs of
59 _ -> drop (I# (n# -# 1#)) xs
61 Notice that the recursive call has an explicit constructor as argument.
62 Noticing this, we can make a specialised version of drop
64 RULE: drop (I# n#) xs ==> drop' n# xs
66 drop' n# xs = let n = I# n# in ...orig RHS...
68 Now the simplifier will apply the specialisation in the rhs of drop', giving
70 drop' n# xs = case xs of
74 _ -> drop (n# -# 1#) xs
78 We'd also like to catch cases where a parameter is carried along unchanged,
79 but evaluated each time round the loop:
81 f i n = if i>0 || i>n then i else f (i*2) n
83 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
84 In Core, by the time we've w/wd (f is strict in i) we get
86 f i# n = case i# ># 0 of
88 True -> case n of n' { I# n# ->
91 True -> f (i# *# 2#) n'
93 At the call to f, we see that the argument, n is know to be (I# n#),
94 and n is evaluated elsewhere in the body of f, so we can play the same
95 trick as above. However we don't want to do that if the boxed version
96 of n is needed (else we'd avoid the eval but pay more for re-boxing n).
97 So in this case we want that the *only* uses of n are in case statements.
102 * A self-recursive function. Ignore mutual recursion for now,
103 because it's less common, and the code is simpler for self-recursion.
107 a) At a recursive call, one or more parameters is an explicit
108 constructor application
110 That same parameter is scrutinised by a case somewhere in
111 the RHS of the function
115 b) At a recursive call, one or more parameters has an unfolding
116 that is an explicit constructor application
118 That same parameter is scrutinised by a case somewhere in
119 the RHS of the function
121 Those are the only uses of the parameter
124 There's a bit of a complication with type arguments. If the call
127 f p = ...f ((:) [a] x xs)...
129 then our specialised function look like
131 f_spec x xs = let p = (:) [a] x xs in ....as before....
133 This only makes sense if either
134 a) the type variable 'a' is in scope at the top of f, or
135 b) the type variable 'a' is an argument to f (and hence fs)
137 Actually, (a) may hold for value arguments too, in which case
138 we may not want to pass them. Supose 'x' is in scope at f's
139 defn, but xs is not. Then we'd like
141 f_spec xs = let p = (:) [a] x xs in ....as before....
143 Similarly (b) may hold too. If x is already an argument at the
144 call, no need to pass it again.
146 Finally, if 'a' is not in scope at the call site, we could abstract
147 it as we do the term variables:
149 f_spec a x xs = let p = (:) [a] x xs in ...as before...
151 So the grand plan is:
153 * abstract the call site to a constructor-only pattern
154 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
156 * Find the free variables of the abstracted pattern
158 * Pass these variables, less any that are in scope at
162 NOTICE that we only abstract over variables that are not in scope,
163 so we're in no danger of shadowing variables used in "higher up"
167 %************************************************************************
169 \subsection{Top level wrapper stuff}
171 %************************************************************************
174 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
175 specConstrProgram dflags us binds
177 showPass dflags "SpecConstr"
179 let (binds', _) = initUs us (go emptyScEnv binds)
181 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
183 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
184 (vcat (map dump_specs (concat (map bindersOf binds'))))
188 go env [] = returnUs []
189 go env (bind:binds) = scBind env bind `thenUs` \ (env', _, bind') ->
190 go env' binds `thenUs` \ binds' ->
191 returnUs (bind' : binds')
193 dump_specs var = pprCoreRules var (idSpecialisation var)
197 %************************************************************************
199 \subsection{Environment: goes downwards}
201 %************************************************************************
204 data ScEnv = SCE { scope :: VarEnv HowBound,
205 -- Binds all non-top-level variables in scope
210 type ConstrEnv = IdEnv (AltCon, [CoreArg])
211 -- Variables known to be bound to a constructor
212 -- in a particular case alternative
214 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
216 data HowBound = RecFun -- These are the recursive functions for which
217 -- we seek interesting call patterns
219 | RecArg -- These are those functions' arguments; we are
220 -- interested to see if those arguments are scrutinised
222 | Other -- We track all others so we know what's in scope
223 -- This is used in spec_one to check what needs to be
224 -- passed as a parameter and what is in scope at the
225 -- function definition site
227 instance Outputable HowBound where
228 ppr RecFun = text "RecFun"
229 ppr RecArg = text "RecArg"
230 ppr Other = text "Other"
232 lookupScopeEnv env v = lookupVarEnv (scope env) v
234 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
235 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
240 -- we want to bind b, and perhaps scrut too, to (C x y)
241 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
242 extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
243 = extendBndrs env (case_bndr : alt_bndrs)
245 extendCaseBndrs env case_bndr scrut con alt_bndrs
247 Var v -> -- Bind the scrutinee in the ConstrEnv if it's a variable
248 -- Also forget if the scrutinee is a RecArg, because we're
249 -- now in the branch of a case, and we don't want to
250 -- record a non-scrutinee use of v if we have
251 -- case v of { (a,b) -> ...(f v)... }
252 SCE { scope = extendVarEnv (scope env1) v Other,
253 cons = extendVarEnv (cons env1) v (con,args) }
257 env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
258 cons = extendVarEnv (cons env) case_bndr (con,args) }
260 args = map Type (tyConAppArgs (idType case_bndr)) ++
261 map varToCoreExpr alt_bndrs
263 -- When we encounter a recursive function binding
265 -- we want to extend the scope env with bindings
266 -- that record that f is a RecFn and x,y are RecArgs
267 extendRecBndr env fn bndrs
268 = env { scope = scope env `extendVarEnvList`
269 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
273 %************************************************************************
275 \subsection{Usage information: flows upwards}
277 %************************************************************************
282 calls :: !(IdEnv ([Call])), -- Calls
283 -- The functions are a subset of the
284 -- RecFuns in the ScEnv
286 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
287 } -- The variables are a subset of the
288 -- RecArg in the ScEnv
290 type Call = (ConstrEnv, [CoreArg])
291 -- The arguments of the call, together with the
292 -- env giving the constructor bindings at the call site
294 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
296 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
297 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
299 combineUsages [] = nullUsage
300 combineUsages us = foldr1 combineUsage us
302 data ArgOcc = CaseScrut
306 instance Outputable ArgOcc where
307 ppr CaseScrut = ptext SLIT("case-scrut")
308 ppr OtherOcc = ptext SLIT("other-occ")
309 ppr Both = ptext SLIT("case-scrut and other")
311 combineOcc CaseScrut CaseScrut = CaseScrut
312 combineOcc OtherOcc OtherOcc = OtherOcc
313 combineOcc _ _ = Both
317 %************************************************************************
319 \subsection{The main recursive function}
321 %************************************************************************
323 The main recursive function gathers up usage information, and
324 creates specialised versions of functions.
327 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
328 -- The unique supply is needed when we invent
329 -- a new name for the specialised function and its args
331 scExpr env e@(Type t) = returnUs (nullUsage, e)
332 scExpr env e@(Lit l) = returnUs (nullUsage, e)
333 scExpr env e@(Var v) = returnUs (varUsage env v OtherOcc, e)
334 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
335 returnUs (usg, Note n e')
336 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
337 returnUs (usg, Lam b e')
339 scExpr env (Case scrut b alts)
340 = sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
341 mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
342 returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
345 sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
346 sc_scrut e = scExpr env e
348 sc_alt (con,bs,rhs) = scExpr env1 rhs `thenUs` \ (usg,rhs') ->
349 returnUs (usg, (con,bs,rhs'))
351 env1 = extendCaseBndrs env b scrut con bs
353 scExpr env (Let bind body)
354 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
355 scExpr env' body `thenUs` \ (body_usg, body') ->
356 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
358 scExpr env e@(App _ _)
360 (fn, args) = collectArgs e
362 mapAndUnzipUs (scExpr env) args `thenUs` \ (usgs, args') ->
364 arg_usg = combineUsages usgs
365 fn_usg | Var f <- fn,
366 Just RecFun <- lookupScopeEnv env f
367 = SCU { calls = unitVarEnv f [(cons env, args)],
372 returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args')
373 -- Don't bother to look inside fn;
374 -- it's almost always a variable
376 ----------------------
377 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
378 scBind env (Rec [(fn,rhs)])
379 | not (null val_bndrs)
380 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
382 SCU { calls = calls, occs = occs } = usg
384 specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
385 returnUs (extendBndr env fn, -- For the body of the letrec, just
386 -- extend the env with Other to record
387 -- that it's in scope; no funny RecFun business
388 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
389 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
391 (bndrs,body) = collectBinders rhs
392 val_bndrs = filter isId bndrs
393 env_fn_body = extendRecBndr env fn bndrs
396 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
397 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
399 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
400 returnUs (usg, (bndr,rhs'))
402 scBind env (NonRec bndr rhs)
403 = scExpr env rhs `thenUs` \ (usg, rhs') ->
404 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
406 ----------------------
408 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
409 occs = unitVarEnv v use }
410 | otherwise = nullUsage
414 %************************************************************************
416 \subsection{The specialiser}
418 %************************************************************************
423 -> [CoreBndr] -> CoreExpr -- Its RHS
424 -> ScUsage -- Info on usage
425 -> UniqSM ([CoreRule], -- Rules
426 [(Id,CoreExpr)]) -- Bindings
428 specialise env fn bndrs body (SCU {calls=calls, occs=occs})
429 = getUs `thenUs` \ us ->
431 all_calls = lookupVarEnv calls fn `orElse` []
433 good_calls :: [[CoreArg]]
435 | (con_env, call_args) <- all_calls,
436 call_args `lengthAtLeast` n_bndrs, -- App is saturated
437 let call = (bndrs `zip` call_args),
438 any (good_arg con_env occs) call, -- At least one arg is a constr app
439 let (_, pats) = argsToPats con_env us call_args
442 mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
443 (nubBy same_call good_calls `zip` [1..])
445 n_bndrs = length bndrs
446 same_call as1 as2 = and (zipWith eqExpr as1 as2)
448 ---------------------
449 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
450 good_arg con_env arg_occs (bndr, arg)
451 = case is_con_app_maybe con_env arg of
452 Just _ -> bndr_usg_ok arg_occs bndr arg
455 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
456 bndr_usg_ok arg_occs bndr arg
457 = case lookupVarEnv arg_occs bndr of
458 Just CaseScrut -> True -- Used only by case scrutiny
459 Just Both -> case arg of -- Used by case and elsewhere
460 App _ _ -> True -- so the arg should be an explicit con app
462 other -> False -- Not used, or used wonkily
465 ---------------------
468 -> CoreExpr -- Rhs of the original function
470 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
472 -- spec_one creates a specialised copy of the function, together
473 -- with a rule for using it. I'm very proud of how short this
474 -- function is, considering what it does :-).
480 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
481 [c::*, v::(b,c) are presumably bound by the (...) part]
483 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
484 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
486 RULE: forall b::* c::*, -- Note, *not* forall a, x
490 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
493 spec_one env fn rhs (pats, rule_number)
494 = getUniqueUs `thenUs` \ spec_uniq ->
497 fn_loc = nameSrcLoc fn_name
498 spec_occ = mkSpecOcc (nameOccName fn_name)
499 pat_fvs = varSetElems (exprsFreeVars pats)
500 vars_to_bind = filter not_avail pat_fvs
501 not_avail v = not (v `elemVarEnv` scope env)
502 -- Put the type variables first; the type of a term
503 -- variable may mention a type variable
504 (tvs, ids) = partition isTyVar vars_to_bind
506 spec_body = mkApps rhs pats
507 body_ty = exprType spec_body
509 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
510 -- Usual w/w hack to avoid generating
511 -- a spec_rhs of unlifted type and no args
513 rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int rule_number))
514 spec_rhs = mkLams spec_lam_args spec_body
515 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
516 rule = Rule rule_name specConstrActivation
517 bndrs pats (mkVarApps (Var spec_id) spec_call_args)
519 returnUs (rule, (spec_id, spec_rhs))
521 -- In which phase should the specialise-constructor rules be active?
522 -- Originally I made them always-active, but Manuel found that
523 -- this defeated some clever user-written rules. So Plan B
524 -- is to make them active only in Phase 0; after all, currently,
525 -- the specConstr transformation is only run after the simplifier
526 -- has reached Phase 0. In general one would want it to be
527 -- flag-controllable, but for now I'm leaving it baked in
529 specConstrActivation :: Activation
530 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
533 %************************************************************************
535 \subsection{Argument analysis}
537 %************************************************************************
539 This code deals with analysing call-site arguments to see whether
540 they are constructor applications.
543 -- argToPat takes an actual argument, and returns an abstracted
544 -- version, consisting of just the "constructor skeleton" of the
545 -- argument, with non-constructor sub-expression replaced by new
546 -- placeholder variables. For example:
547 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
549 argToPat :: ConstrEnv -> UniqSupply -> CoreArg -> (UniqSupply, CoreExpr)
550 argToPat env us (Type ty)
554 | Just (dc,args) <- is_con_app_maybe env arg
556 (us',args') = argsToPats env us args
558 (us', mk_con_app dc args')
560 argToPat env us (Var v) -- Don't uniqify existing vars,
561 = (us, Var v) -- so that we can spot when we pass them twice
564 = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg)))
566 (us1,us2) = splitUniqSupply us
568 argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
569 argsToPats env us args = mapAccumL (argToPat env) us args
574 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe (AltCon, [CoreExpr])
575 is_con_app_maybe env (Var v)
577 -- You might think we could look in the idUnfolding here
578 -- but that doesn't take account of which branch of a
579 -- case we are in, which is the whole point
581 is_con_app_maybe env (Lit lit)
582 = Just (LitAlt lit, [])
584 is_con_app_maybe env expr
585 = case collectArgs expr of
586 (Var fun, args) | Just con <- isDataConId_maybe fun,
587 args `lengthAtLeast` dataConRepArity con
588 -- Might be > because the arity excludes type args
589 -> Just (DataAlt con,args)
593 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
594 mk_con_app (LitAlt lit) [] = Lit lit
595 mk_con_app (DataAlt con) args = mkConApp con args