From: simonpj <unknown>
Date: Wed, 23 Feb 2005 09:13:49 +0000 (+0000)
Subject: [project @ 2005-02-23 09:13:49 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1039
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c685ccf47413f070a85c4b739d9d7cc73e6f38e6

[project @ 2005-02-23 09:13:49 by simonpj]
---------------------------------------------
	Another fix to data2tag evaluated-ness (sigh)
	---------------------------------------------

	Merge to STABLE
---

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 12aca16..d7d2a99 100644
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -560,16 +560,16 @@ maybeSaturate fn expr n_args floats ty
 
 	-- Ensure that the argument of DataToTagOp is evaluated
     eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
-    eval_data2tag_arg app@(fun `App` Var arg_id)
-	| isEvaldUnfolding (idUnfolding arg_id)	-- Includes nullary constructors
+    eval_data2tag_arg app@(fun `App` arg)
+	| exprIsValue arg		-- Includes nullary constructors
 	= returnUs (emptyFloats, app)	-- The arg is evaluated
 	| otherwise			-- Arg not evaluated, so evaluate it
-	= newVar (idType arg_id)		`thenUs` \ arg_id1 ->
+	= newVar (exprType arg)		`thenUs` \ arg_id ->
 	  let 
-	     arg_id2   = setIdUnfolding arg_id1 evaldUnfolding
+	     arg_id1 = setIdUnfolding arg_id evaldUnfolding
 	  in
-	  returnUs (unitFloat (FloatCase arg_id2 (Var arg_id) False ),
-		    fun `App` Var arg_id2)
+	  returnUs (unitFloat (FloatCase arg_id1 arg False ),
+		    fun `App` Var arg_id1)
 
     eval_data2tag_arg (Note note app)	-- Scc notes can appear
 	= eval_data2tag_arg app		`thenUs` \ (floats, app') ->