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 CoreTidy ( pprTidyIdRules )
18 import WwLib ( mkWorkerArgs )
19 import DataCon ( dataConRepArity )
20 import Type ( tyConAppArgs )
21 import Id ( Id, idName, idType,
22 isDataConWorkId_maybe,
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, 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 (vcat (map pprTidyIdRules (concat (map bindersOf 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 (AltCon, [CoreArg])
210 -- Variables known to be bound to a constructor
211 -- in a particular case alternative
213 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
215 data HowBound = RecFun -- These are the recursive functions for which
216 -- we seek interesting call patterns
218 | RecArg -- These are those functions' arguments; we are
219 -- interested to see if those arguments are scrutinised
221 | Other -- We track all others so we know what's in scope
222 -- This is used in spec_one to check what needs to be
223 -- passed as a parameter and what is in scope at the
224 -- function definition site
226 instance Outputable HowBound where
227 ppr RecFun = text "RecFun"
228 ppr RecArg = text "RecArg"
229 ppr Other = text "Other"
231 lookupScopeEnv env v = lookupVarEnv (scope env) v
233 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
234 extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
239 -- we want to bind b, and perhaps scrut too, to (C x y)
240 extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
241 extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
242 = extendBndrs env (case_bndr : alt_bndrs)
244 extendCaseBndrs env case_bndr scrut con alt_bndrs
246 Var v -> -- Bind the scrutinee in the ConstrEnv if it's a variable
247 -- Also forget if the scrutinee is a RecArg, because we're
248 -- now in the branch of a case, and we don't want to
249 -- record a non-scrutinee use of v if we have
250 -- case v of { (a,b) -> ...(f v)... }
251 SCE { scope = extendVarEnv (scope env1) v Other,
252 cons = extendVarEnv (cons env1) v (con,args) }
256 env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
257 cons = extendVarEnv (cons env) case_bndr (con,args) }
259 args = map Type (tyConAppArgs (idType case_bndr)) ++
260 map varToCoreExpr alt_bndrs
262 -- When we encounter a recursive function binding
264 -- we want to extend the scope env with bindings
265 -- that record that f is a RecFn and x,y are RecArgs
266 extendRecBndr env fn bndrs
267 = env { scope = scope env `extendVarEnvList`
268 ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
272 %************************************************************************
274 \subsection{Usage information: flows upwards}
276 %************************************************************************
281 calls :: !(IdEnv ([Call])), -- Calls
282 -- The functions are a subset of the
283 -- RecFuns in the ScEnv
285 occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
286 } -- The variables are a subset of the
287 -- RecArg in the ScEnv
289 type Call = (ConstrEnv, [CoreArg])
290 -- The arguments of the call, together with the
291 -- env giving the constructor bindings at the call site
293 nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }
295 combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
296 occs = plusVarEnv_C combineOcc (occs u1) (occs u2) }
298 combineUsages [] = nullUsage
299 combineUsages us = foldr1 combineUsage us
301 data ArgOcc = CaseScrut
305 instance Outputable ArgOcc where
306 ppr CaseScrut = ptext SLIT("case-scrut")
307 ppr OtherOcc = ptext SLIT("other-occ")
308 ppr Both = ptext SLIT("case-scrut and other")
310 combineOcc CaseScrut CaseScrut = CaseScrut
311 combineOcc OtherOcc OtherOcc = OtherOcc
312 combineOcc _ _ = Both
316 %************************************************************************
318 \subsection{The main recursive function}
320 %************************************************************************
322 The main recursive function gathers up usage information, and
323 creates specialised versions of functions.
326 scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
327 -- The unique supply is needed when we invent
328 -- a new name for the specialised function and its args
330 scExpr env e@(Type t) = returnUs (nullUsage, e)
331 scExpr env e@(Lit l) = returnUs (nullUsage, e)
332 scExpr env e@(Var v) = returnUs (varUsage env v OtherOcc, e)
333 scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') ->
334 returnUs (usg, Note n e')
335 scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
336 returnUs (usg, Lam b e')
339 scExpr env (Case scrut b ty alts)
340 = sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
341 mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
343 returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
344 Case scrut' b ty alts')
346 sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
347 sc_scrut e = scExpr env e
349 sc_alt (con,bs,rhs) = scExpr env1 rhs `thenUs` \ (usg,rhs') ->
350 returnUs (usg, (con,bs,rhs'))
352 env1 = extendCaseBndrs env b scrut con bs
354 scExpr env (Let bind body)
355 = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
356 scExpr env' body `thenUs` \ (body_usg, body') ->
357 returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
359 scExpr env e@(App _ _)
361 (fn, args) = collectArgs e
363 mapAndUnzipUs (scExpr env) args `thenUs` \ (usgs, args') ->
365 arg_usg = combineUsages usgs
366 fn_usg | Var f <- fn,
367 Just RecFun <- lookupScopeEnv env f
368 = SCU { calls = unitVarEnv f [(cons env, args)],
373 returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args')
374 -- Don't bother to look inside fn;
375 -- it's almost always a variable
377 ----------------------
378 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
379 scBind env (Rec [(fn,rhs)])
381 = scExpr env_fn_body body `thenUs` \ (usg, body') ->
383 SCU { calls = calls, occs = occs } = usg
385 specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
386 returnUs (extendBndr env fn, -- For the body of the letrec, just
387 -- extend the env with Other to record
388 -- that it's in scope; no funny RecFun business
389 SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
390 Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
392 (bndrs,body) = collectBinders rhs
393 val_bndrs = filter isId bndrs
394 env_fn_body = extendRecBndr env fn bndrs
397 = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
398 returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
400 do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
401 returnUs (usg, (bndr,rhs'))
403 scBind env (NonRec bndr rhs)
404 = scExpr env rhs `thenUs` \ (usg, rhs') ->
405 returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
407 ----------------------
409 | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv,
410 occs = unitVarEnv v use }
411 | otherwise = nullUsage
415 %************************************************************************
417 \subsection{The specialiser}
419 %************************************************************************
424 -> [CoreBndr] -> CoreExpr -- Its RHS
425 -> ScUsage -- Info on usage
426 -> UniqSM ([CoreRule], -- Rules
427 [(Id,CoreExpr)]) -- Bindings
429 specialise env fn bndrs body (SCU {calls=calls, occs=occs})
430 = getUs `thenUs` \ us ->
432 all_calls = lookupVarEnv calls fn `orElse` []
434 good_calls :: [[CoreArg]]
436 | (con_env, call_args) <- all_calls,
437 call_args `lengthAtLeast` n_bndrs, -- App is saturated
438 let call = (bndrs `zip` call_args),
439 any (good_arg con_env occs) call, -- At least one arg is a constr app
440 let (_, pats) = argsToPats con_env us call_args
443 mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
444 (nubBy same_call good_calls `zip` [1..])
446 n_bndrs = length bndrs
447 same_call as1 as2 = and (zipWith eqExpr as1 as2)
449 ---------------------
450 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
451 good_arg con_env arg_occs (bndr, arg)
452 = case is_con_app_maybe con_env arg of
453 Just _ -> bndr_usg_ok arg_occs bndr arg
456 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
457 bndr_usg_ok arg_occs bndr arg
458 = case lookupVarEnv arg_occs bndr of
459 Just CaseScrut -> True -- Used only by case scrutiny
460 Just Both -> case arg of -- Used by case and elsewhere
461 App _ _ -> True -- so the arg should be an explicit con app
463 other -> False -- Not used, or used wonkily
466 ---------------------
469 -> CoreExpr -- Rhs of the original function
471 -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding
473 -- spec_one creates a specialised copy of the function, together
474 -- with a rule for using it. I'm very proud of how short this
475 -- function is, considering what it does :-).
481 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
482 [c::*, v::(b,c) are presumably bound by the (...) part]
484 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
485 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
487 RULE: forall b::* c::*, -- Note, *not* forall a, x
491 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
494 spec_one env fn rhs (pats, rule_number)
495 = getUniqueUs `thenUs` \ spec_uniq ->
498 fn_loc = nameSrcLoc fn_name
499 spec_occ = mkSpecOcc (nameOccName fn_name)
500 pat_fvs = varSetElems (exprsFreeVars pats)
501 vars_to_bind = filter not_avail pat_fvs
502 not_avail v = not (v `elemVarEnv` scope env)
503 -- Put the type variables first; the type of a term
504 -- variable may mention a type variable
505 (tvs, ids) = partition isTyVar vars_to_bind
507 spec_body = mkApps rhs pats
508 body_ty = exprType spec_body
510 (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
511 -- Usual w/w hack to avoid generating
512 -- a spec_rhs of unlifted type and no args
514 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
515 spec_rhs = mkLams spec_lam_args spec_body
516 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
517 rule = Rule rule_name specConstrActivation
518 bndrs pats (mkVarApps (Var spec_id) spec_call_args)
520 returnUs (rule, (spec_id, spec_rhs))
522 -- In which phase should the specialise-constructor rules be active?
523 -- Originally I made them always-active, but Manuel found that
524 -- this defeated some clever user-written rules. So Plan B
525 -- is to make them active only in Phase 0; after all, currently,
526 -- the specConstr transformation is only run after the simplifier
527 -- has reached Phase 0. In general one would want it to be
528 -- flag-controllable, but for now I'm leaving it baked in
530 specConstrActivation :: Activation
531 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
534 %************************************************************************
536 \subsection{Argument analysis}
538 %************************************************************************
540 This code deals with analysing call-site arguments to see whether
541 they are constructor applications.
544 -- argToPat takes an actual argument, and returns an abstracted
545 -- version, consisting of just the "constructor skeleton" of the
546 -- argument, with non-constructor sub-expression replaced by new
547 -- placeholder variables. For example:
548 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
550 argToPat :: ConstrEnv -> UniqSupply -> CoreArg -> (UniqSupply, CoreExpr)
551 argToPat env us (Type ty)
555 | Just (dc,args) <- is_con_app_maybe env arg
557 (us',args') = argsToPats env us args
559 (us', mk_con_app dc args')
561 argToPat env us (Var v) -- Don't uniqify existing vars,
562 = (us, Var v) -- so that we can spot when we pass them twice
565 = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
567 (us1,us2) = splitUniqSupply us
569 argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
570 argsToPats env us args = mapAccumL (argToPat env) us args
575 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe (AltCon, [CoreExpr])
576 is_con_app_maybe env (Var v)
578 -- You might think we could look in the idUnfolding here
579 -- but that doesn't take account of which branch of a
580 -- case we are in, which is the whole point
582 is_con_app_maybe env (Lit lit)
583 = Just (LitAlt lit, [])
585 is_con_app_maybe env expr
586 = case collectArgs expr of
587 (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
588 args `lengthAtLeast` dataConRepArity con
589 -- Might be > because the arity excludes type args
590 -> Just (DataAlt con,args)
594 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
595 mk_con_app (LitAlt lit) [] = Lit lit
596 mk_con_app (DataAlt con) args = mkConApp con args