From: simonpj <unknown>
Date: Wed, 5 Dec 2001 15:00:21 +0000 (+0000)
Subject: [project @ 2001-12-05 15:00:21 by simonpj]
X-Git-Tag: Approximately_9120_patches~462
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b6fc61047ea6400e871a2ecca90738c56db19b97;p=ghc-hetmet.git

[project @ 2001-12-05 15:00:21 by simonpj]
Preserve IdInfo for strict binders
---

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index a318c66..8f1b22f 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -294,16 +294,22 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
 
   | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr)	-- A strict let
   =  	-- Don't use simplBinder because that doesn't keep 
-	-- fragile occurrence in the substitution
+	-- fragile occurrence info in the substitution
     simplLetBndr env bndr					`thenSmpl` \ (env, bndr') ->
-    simplStrictArg AnRhs env rhs rhs_se (idType bndr') cont_ty	$ \ env rhs1 ->
+    let
+	-- simplLetBndr doesn't deal with the IdInfo, so we must
+	-- do so here (c.f. simplLazyBind)
+	bndr''  = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+	env1	= modifyInScope env bndr'' bndr''
+    in
+    simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty	$ \ env rhs1 ->
 
 	-- Now complete the binding and simplify the body
-    completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside
+    completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside
 
   | otherwise							-- Normal, lazy case
   =  	-- Don't use simplBinder because that doesn't keep 
-	-- fragile occurrence in the substitution
+	-- fragile occurrence info in the substitution
     simplLetBndr env bndr				`thenSmpl` \ (env, bndr') ->
     simplLazyBind env NotTopLevel NonRecursive
 		  bndr bndr' rhs rhs_se 		`thenSmpl` \ (floats, env) ->
@@ -441,13 +447,12 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
 	--
 	-- NB: does no harm for non-recursive bindings
     let
- 	is_top_level	  = isTopLevel top_lvl
-	bndr_ty'     	  = idType bndr'
-	bndr''       	  = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
+	bndr''       	  = bndr' `setIdInfo` simplIdInfo (getSubst rhs_se) (idInfo bndr)
 	env1	     	  = modifyInScope env bndr'' bndr''
 	rhs_env      	  = setInScope rhs_se env1
+ 	is_top_level	  = isTopLevel top_lvl
 	ok_float_unlifted = not is_top_level && isNonRec is_rec
-	rhs_cont	  = mkStop bndr_ty' AnRhs
+	rhs_cont	  = mkStop (idType bndr') AnRhs
     in
   	-- Simplify the RHS; note the mkStop, which tells 
 	-- the simplifier that this is the RHS of a let.