import CoreSyn
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprType, exprIsConApp_maybe, eqExpr )
+import CoreUtils ( exprType, eqExpr, mkPiTypes )
import CoreFVs ( exprsFreeVars )
+import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
import PprCore ( pprCoreRules )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..) )
+import BasicTypes ( Activation(..) )
import Outputable
import Maybes ( orElse )
-import Util ( mapAccumL )
+import Util ( mapAccumL, lengthAtLeast )
import List ( nubBy, partition )
import UniqSupply
import Outputable
-- passed as a parameter and what is in scope at the
-- function definition site
+instance Outputable HowBound where
+ ppr RecFun = text "RecFun"
+ ppr RecArg = text "RecArg"
+ ppr Other = text "Other"
+
lookupScopeEnv env v = lookupVarEnv (scope env) v
extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
-- case scrut of b
-- C x y -> ...
-- we want to bind b, and perhaps scrut too, to (C x y)
-extendCaseBndr env case_bndr scrut con alt_bndrs
+extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
+extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
+ = extendBndrs env (case_bndr : alt_bndrs)
+
+extendCaseBndrs env case_bndr scrut con alt_bndrs
= case scrut of
Var v -> -- Bind the scrutinee in the ConstrEnv if it's a variable
-- Also forget if the scrutinee is a RecArg, because we're
sc_alt (con,bs,rhs) = scExpr env1 rhs `thenUs` \ (usg,rhs') ->
returnUs (usg, (con,bs,rhs'))
where
- env1 = extendCaseBndr env b scrut con bs
+ env1 = extendCaseBndrs env b scrut con bs
scExpr env (Let bind body)
= scBind env bind `thenUs` \ (env', bind_usg, bind') ->
scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
scBind env (Rec [(fn,rhs)])
| not (null val_bndrs)
- = scExpr env' body `thenUs` \ (usg, body') ->
+ = scExpr env_fn_body body `thenUs` \ (usg, body') ->
let
SCU { calls = calls, occs = occs } = usg
in
specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
- returnUs (extendBndrs env bndrs,
+ returnUs (extendBndr env fn, -- For the body of the letrec, just
+ -- extend the env with Other to record
+ -- that it's in scope; no funny RecFun business
SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
where
(bndrs,body) = collectBinders rhs
val_bndrs = filter isId bndrs
- env' = extendRecBndr env fn bndrs
+ env_fn_body = extendRecBndr env fn bndrs
scBind env (Rec prs)
= mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') ->
good_calls :: [[CoreArg]]
good_calls = [ pats
| (con_env, call_args) <- all_calls,
- length call_args >= n_bndrs, -- App is saturated
+ call_args `lengthAtLeast` n_bndrs, -- App is saturated
let call = (bndrs `zip` call_args),
any (good_arg con_env occs) call, -- At least one arg is a constr app
let (_, pats) = argsToPats con_env us call_args
]
in
- pprTrace "specialise" (ppr all_calls $$ ppr good_calls) $
mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
(nubBy same_call good_calls `zip` [1..])
where
bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
bndr_usg_ok arg_occs bndr arg
- = pprTrace "bndr_ok" (ppr bndr <+> ppr (lookupVarEnv arg_occs bndr)) $
- case lookupVarEnv arg_occs bndr of
+ = case lookupVarEnv arg_occs bndr of
Just CaseScrut -> True -- Used only by case scrutiny
Just Both -> case arg of -- Used by case and elsewhere
App _ _ -> True -- so the arg should be an explicit con app
Example
In-scope: a, x::a
- f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) v (h v))...
- [c is presumably bound by the (...) part]
+ f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
+ [c::*, v::(b,c) are presumably bound by the (...) part]
==>
- f_spec = /\ b c \ v::(a,(b,c)) ->
- (...entire RHS of f...) (b,c) ((:) (a,(b,c)) v (h v))
+ f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
+ (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
- RULE: forall b c,
- y::[(a,(b,c))],
- v::(a,(b,c)),
- h::(a,(b,c))->[(a,(b,c))] .
+ RULE: forall b::* c::*, -- Note, *not* forall a, x
+ v::(b,c),
+ hw::[(a,(b,c))] .
- f (b,c) ((:) (a,(b,c)) v (h v)) = f_spec b c v
+ f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
-}
-spec_one env fn rhs (pats, n)
- = getUniqueUs `thenUs` \ spec_uniq ->
+spec_one env fn rhs (pats, rule_number)
+ = getUniqueUs `thenUs` \ spec_uniq ->
let
fn_name = idName fn
fn_loc = nameSrcLoc fn_name
pat_fvs = varSetElems (exprsFreeVars pats)
vars_to_bind = filter not_avail pat_fvs
not_avail v = not (v `elemVarEnv` scope env)
- -- Put the type variables first just for tidiness
+ -- Put the type variables first; the type of a term
+ -- variable may mention a type variable
(tvs, ids) = partition isTyVar vars_to_bind
bndrs = tvs ++ ids
+ spec_body = mkApps rhs pats
+ body_ty = exprType spec_body
- rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n))
- spec_rhs = mkLams bndrs (mkApps rhs pats)
- spec_id = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc
- rule = Rule rule_name pat_fvs pats (mkVarApps (Var spec_id) bndrs)
+ (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
+ -- Usual w/w hack to avoid generating
+ -- a spec_rhs of unlifted type and no args
+
+ rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int rule_number))
+ spec_rhs = mkLams spec_lam_args spec_body
+ spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
+ rule = Rule rule_name specConstrActivation
+ bndrs pats (mkVarApps (Var spec_id) spec_call_args)
in
returnUs (rule, (spec_id, spec_rhs))
+
+-- In which phase should the specialise-constructor rules be active?
+-- Originally I made them always-active, but Manuel found that
+-- this defeated some clever user-written rules. So Plan B
+-- is to make them active only in Phase 0; after all, currently,
+-- the specConstr transformation is only run after the simplifier
+-- has reached Phase 0. In general one would want it to be
+-- flag-controllable, but for now I'm leaving it baked in
+-- [SLPJ Oct 01]
+specConstrActivation :: Activation
+specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
\end{code}
%************************************************************************
= (us, Var v) -- so that we can spot when we pass them twice
argToPat env us arg
- = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg)))
+ = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
where
(us1,us2) = splitUniqSupply us
is_con_app_maybe env expr
= case collectArgs expr of
(Var fun, args) | Just con <- isDataConId_maybe fun,
- length args >= dataConRepArity con
+ args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
-> Just (DataAlt con,args)
projects / ghc-hetmet.git / blobdiff