From 6e04c7e8ce404d4c2552e7118f1ece20b2632e92 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 24 May 2000 11:39:48 +0000
Subject: [PATCH] [project @ 2000-05-24 11:39:48 by simonpj] MERGE 4.07
* When float outwards (full laziness) remember to
switch off the demand flag. Else we wrongly
can transform
\x -> let y __D = (...) in y+x
into
let y __D = (...)
in \x -> y+x
In the latter, y is not necessarily demanded;
it depends whether the function is called. We
should switch off the demand flag.
The fix is right at the bottom in SetLevels.subst_id_info
---
ghc/compiler/simplCore/SetLevels.lhs | 49 +++++++++++++++++-----------
1 file changed, 30 insertions(+), 19 deletions(-)
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index f95828cfacd7..82ab0251310a 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -47,7 +47,7 @@ import CoreFVs -- all of it
import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
-import IdInfo ( workerExists, vanillaIdInfo )
+import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
import Var ( Var, TyVar, setVarUnique )
import VarEnv
import Subst
@@ -56,6 +56,7 @@ import Name ( getOccName )
import OccName ( occNameUserString )
import Type ( isUnLiftedType, mkPiType, Type )
import BasicTypes ( TopLevelFlag(..) )
+import Demand ( isStrict, wwLazy )
import VarSet
import VarEnv
import UniqSupply
@@ -342,7 +343,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
| null abs_vars
= -- No type abstraction; clone existing binder
lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
- cloneVar top_lvl env bndr dest_lvl `thenLvl` \ (env', bndr') ->
+ cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') ->
returnLvl (NonRec (bndr', dest_lvl) rhs', env')
| otherwise
@@ -366,8 +367,8 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
\begin{code}
lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
| null abs_vars
- = cloneVars top_lvl env bndrs dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
- mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->
+ = cloneVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
+ mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->
returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
| isSingleton pairs && count isId abs_vars > 1
@@ -386,7 +387,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
(rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars
rhs_env = extendLvlEnv env abs_vars_w_lvls
in
- cloneVar NotTopLevel rhs_env bndr rhs_lvl `thenLvl` \ (rhs_env', new_bndr) ->
+ cloneVar NotTopLevel rhs_env bndr rhs_lvl rhs_lvl `thenLvl` \ (rhs_env', new_bndr) ->
let
(lam_bndrs, rhs_body) = collect_binders rhs
(body_lvl, new_lam_bndrs) = lvlLamBndrs rhs_lvl lam_bndrs
@@ -401,8 +402,8 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
poly_env)
| otherwise
- = newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
- mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
+ = newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
+ mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
where
@@ -669,33 +670,43 @@ newLvlVar str vars body_ty
-- The deeply tiresome thing is that we have to apply the substitution
-- to the rules inside each Id. Grr. But it matters.
-cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id)
-cloneVar TopLevel env v lvl
+cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
+cloneVar TopLevel env v ctxt_lvl dest_lvl
= returnUs (env, v) -- Don't clone top level things
-cloneVar NotTopLevel env v lvl
+cloneVar NotTopLevel env v ctxt_lvl dest_lvl
= getUniqueUs `thenLvl` \ uniq ->
let
v' = setVarUnique v uniq
- v'' = subst_id_info env v'
- env' = extendCloneLvlEnv lvl env [(v,v'')]
+ v'' = subst_id_info env ctxt_lvl dest_lvl v'
+ env' = extendCloneLvlEnv dest_lvl env [(v,v'')]
in
returnUs (env', v'')
-cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
-cloneVars TopLevel env vs lvl
+cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id])
+cloneVars TopLevel env vs ctxt_lvl dest_lvl
= returnUs (env, vs) -- Don't clone top level things
-cloneVars NotTopLevel env vs lvl
+cloneVars NotTopLevel env vs ctxt_lvl dest_lvl
= getUniquesUs (length vs) `thenLvl` \ uniqs ->
let
vs' = zipWith setVarUnique vs uniqs
- vs'' = map (subst_id_info env') vs'
- env' = extendCloneLvlEnv lvl env (vs `zip` vs'')
+ vs'' = map (subst_id_info env' ctxt_lvl dest_lvl) vs'
+ env' = extendCloneLvlEnv dest_lvl env (vs `zip` vs'')
in
returnUs (env', vs'')
-subst_id_info (_, _, subst_env, _) v
- = modifyIdInfo (\info -> substIdInfo subst info info) v
+subst_id_info (_, _, subst_env, _) ctxt_lvl dest_lvl v
+ = modifyIdInfo (\info -> substIdInfo subst info (zap_dmd info)) v
where
subst = mkSubst emptyVarSet subst_env
+
+ -- VERY IMPORTANT: we must zap the demand info
+ -- if the thing is going to float out past a lambda
+ zap_dmd info
+ | float_past_lam && isStrict (demandInfo info)
+ = setDemandInfo info wwLazy
+ | otherwise
+ = info
+
+ float_past_lam = ctxt_lvl `ltMajLvl` dest_lvl
\end{code}
--
GitLab