Commit 098d99aa authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Inline into tail-called constructor args

Consider
	x = case y of { True -> (p,q); ... }

The occurrence analyser was marking p,q as 'Many', because they args
of a constructor in an RhsCtxt.  But actually they aren't in a RhsCtxt,
and in this case it's better to inline.
parent 25ce05f7
...@@ -502,8 +502,8 @@ occAnal env expr@(Lam _ _) ...@@ -502,8 +502,8 @@ occAnal env expr@(Lam _ _)
is_one_shot b = isId b && isOneShotBndr b is_one_shot b = isId b && isOneShotBndr b
occAnal env (Case scrut bndr ty alts) occAnal env (Case scrut bndr ty alts)
= case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') -> case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
let let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage' = addCaseBndrUsage alts_usage alts_usage' = addCaseBndrUsage alts_usage
...@@ -523,6 +523,10 @@ occAnal env (Case scrut bndr ty alts) ...@@ -523,6 +523,10 @@ occAnal env (Case scrut bndr ty alts)
Nothing -> usage Nothing -> usage
Just occ -> extendVarEnv usage bndr (markMany occ) Just occ -> extendVarEnv usage bndr (markMany occ)
alt_env = setVanillaCtxt env
-- Consider x = case v of { True -> (p,q); ... }
-- Then it's fine to inline p and q
occ_anal_scrut (Var v) (alt1 : other_alts) occ_anal_scrut (Var v) (alt1 : other_alts)
| not (null other_alts) || not (isDefaultAlt alt1) | not (null other_alts) || not (isDefaultAlt alt1)
= (mkOneOcc env v True, Var v) = (mkOneOcc env v True, Var v)
...@@ -545,7 +549,6 @@ Applications are dealt with specially because we want ...@@ -545,7 +549,6 @@ Applications are dealt with specially because we want
the "build hack" to work. the "build hack" to work.
\begin{code} \begin{code}
-- Hack for build, fold, runST
occAnalApp env (Var fun, args) is_rhs occAnalApp env (Var fun, args) is_rhs
= case args_stuff of { (args_uds, args') -> = case args_stuff of { (args_uds, args') ->
let let
...@@ -566,6 +569,8 @@ occAnalApp env (Var fun, args) is_rhs ...@@ -566,6 +569,8 @@ occAnalApp env (Var fun, args) is_rhs
where where
fun_uniq = idUnique fun fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0) fun_uds = mkOneOcc env fun (valArgCount args > 0)
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
| fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
...@@ -685,6 +690,10 @@ rhsCtxt = OccEnv OccRhs [] ...@@ -685,6 +690,10 @@ rhsCtxt = OccEnv OccRhs []
isRhsEnv (OccEnv OccRhs _) = True isRhsEnv (OccEnv OccRhs _) = True
isRhsEnv (OccEnv OccVanilla _) = False isRhsEnv (OccEnv OccVanilla _) = False
setVanillaCtxt :: OccEnv -> OccEnv
setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
setVanillaCtxt other_env = other_env
setCtxt :: OccEnv -> CtxtTy -> OccEnv setCtxt :: OccEnv -> CtxtTy -> OccEnv
setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
......
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