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 f95828c..82ab025 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}
 	
-- 
1.7.10.4