Commit 64f00b23 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Fix constructor-specialisation bug

The constructor-specialisation optimisation was not dealing with the case
of 
	(letrec ... in f) a1 a2

We need to apply constructor specialisation in the letrec; previously
we were leaving it untouched on the grounds that the function part of
an application is almost always a variable.

But in fact, float-in immediately precedes SpecConstr, so we can get
these odd-looking applications.
parent 381b1a62
......@@ -211,6 +211,10 @@ data ConValue = CV AltCon [CoreArg]
-- Variables known to be bound to a constructor
-- in a particular case alternative
instance Outputable ConValue where
ppr (CV con args) = ppr con <+> interpp'SP args
refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
-- The substitution is a type substitution only
refineConstrEnv subst env = mapVarEnv refine_con_value env
......@@ -391,29 +395,30 @@ scExpr env e@(App _ _)
= let
(fn, args) = collectArgs e
in
mapAndUnzipUs (scExpr env) args `thenUs` \ (usgs, args') ->
mapAndUnzipUs (scExpr env) (fn:args) `thenUs` \ (usgs, (fn':args')) ->
-- Process the function too. It's almost always a variable,
-- but not always. In particular, if this pass follows float-in,
-- which it may, we can get
-- (let f = ...f... in f) arg1 arg2
let
arg_usg = combineUsages usgs
fn_usg | Var f <- fn,
Just RecFun <- lookupScopeEnv env f
= SCU { calls = unitVarEnv f [(cons env, args)],
occs = emptyVarEnv }
| otherwise
= nullUsage
call_usg = case fn of
Var f | Just RecFun <- lookupScopeEnv env f
-> SCU { calls = unitVarEnv f [(cons env, args)],
occs = emptyVarEnv }
other -> nullUsage
in
returnUs (arg_usg `combineUsage` fn_usg, mkApps fn args')
-- Don't bother to look inside fn;
-- it's almost always a variable
returnUs (combineUsages usgs `combineUsage` call_usg, mkApps fn' args')
----------------------
scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
scBind env (Rec [(fn,rhs)])
| notNull val_bndrs
= scExpr env_fn_body body `thenUs` \ (usg, body') ->
specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
let
SCU { calls = calls, occs = occs } = usg
in
specialise env fn bndrs body usg `thenUs` \ (rules, spec_prs) ->
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment