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

[project @ 2005-02-02 13:28:05 by simonpj]
Make sure that the argument of DataToTag is evaluated; rather a horrible piece of code, I fear
---

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 9daa46d..12aca16 100644
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -320,6 +320,7 @@ corePrepRecPairs lvl env pairs
 
     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
+    get b			prs2 = pprPanic "corePrepRecPairs" (ppr b)
 
 --------------------------------
 corePrepRhs :: TopLevelFlag -> RecFlag
@@ -497,9 +498,10 @@ corePrepExprFloat env expr@(App _ _)
 	  returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 
     collect_args (Note note fun) depth
-	| ignore_note note 
+	| ignore_note note 	-- Drop these notes altogether
+				-- They aren't used by the code generator
         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
-	  returnUs (Note note fun', hd, fun_ty, floats, ss)
+	  returnUs (fun', hd, fun_ty, floats, ss)
 
 	-- N-variable fun, better let-bind it
 	-- ToDo: perhaps we can case-bind rather than let-bind this closure,
@@ -526,29 +528,55 @@ corePrepExprFloat env expr@(App _ _)
 -- The type is the type of the entire application
 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
 maybeSaturate fn expr n_args floats ty
-  | hasNoBinding fn = saturate_it
+  | Just DataToTagOp <- isPrimOpId_maybe fn	-- DataToTag must have an evaluated arg
+						-- A gruesome special case
+  = saturate_it		`thenUs` \ sat_expr ->
+
+	-- OK, now ensure that the arg is evaluated.
+	-- But (sigh) take into account the lambdas we've now introduced
+    let 
+	(eta_bndrs, eta_body) = collectBinders sat_expr
+    in
+    eval_data2tag_arg eta_body	`thenUs` \ (eta_floats, eta_body') -> 
+    if null eta_bndrs then
+	returnUs (floats `appendFloats` eta_floats, eta_body')
+    else
+	mkBinds eta_floats eta_body'		`thenUs` \ eta_body'' ->
+	returnUs (floats, mkLams eta_bndrs eta_body'')
+
+  | hasNoBinding fn = saturate_it	`thenUs` \ sat_expr ->
+		      returnUs (floats, sat_expr)
+
   | otherwise       = returnUs (floats, expr)
+
   where
     fn_arity	 = idArity fn
     excess_arity = fn_arity - n_args
-    saturate_it  = getUniquesUs		`thenUs` \ us ->
-		   let expr' = etaExpand excess_arity us expr ty in
-		   case isPrimOpId_maybe fn of
-			Just DataToTagOp -> hack_data2tag expr'
-			other		 -> returnUs (floats, expr')
+
+    saturate_it :: UniqSM CoreExpr
+    saturate_it | excess_arity == 0 = returnUs expr
+		| otherwise	    = getUniquesUs		`thenUs` \ us ->
+				      returnUs (etaExpand excess_arity us expr ty)
 
 	-- Ensure that the argument of DataToTagOp is evaluated
-    hack_data2tag app@(Var _fn `App` _ty `App` Var arg_id)
+    eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
+    eval_data2tag_arg app@(fun `App` Var arg_id)
 	| isEvaldUnfolding (idUnfolding arg_id)	-- Includes nullary constructors
-	= returnUs (floats, app)	-- The arg is evaluated
-    hack_data2tag app@(Var fn `App` Type ty `App` arg)
+	= returnUs (emptyFloats, app)	-- The arg is evaluated
 	| otherwise			-- Arg not evaluated, so evaluate it
-	= newVar ty		`thenUs` \ arg_id1 ->
-	  let arg_id2   = setIdUnfolding arg_id1 evaldUnfolding
-	      new_float = FloatCase arg_id2 arg False 
+	= newVar (idType arg_id)		`thenUs` \ arg_id1 ->
+	  let 
+	     arg_id2   = setIdUnfolding arg_id1 evaldUnfolding
 	  in
-	  returnUs (addFloat floats new_float, 
-		    Var fn `App` Type ty `App` Var arg_id2)
+	  returnUs (unitFloat (FloatCase arg_id2 (Var arg_id) False ),
+		    fun `App` Var arg_id2)
+
+    eval_data2tag_arg (Note note app)	-- Scc notes can appear
+	= eval_data2tag_arg app		`thenUs` \ (floats, app') ->
+	  returnUs (floats, Note note app')
+
+    eval_data2tag_arg other	-- Should not happen
+	= pprPanic "eval_data2tag" (ppr other)
 
 
 -- ---------------------------------------------------------------------------
@@ -614,6 +642,7 @@ mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
 mkBinds (Floats _ binds) body 
   | isNilOL binds = returnUs body
   | otherwise	  = deLam body		`thenUs` \ body' ->
+			-- Lambdas are not allowed as the body of a 'let'
 		    returnUs (foldrOL mk_bind body' binds)
   where
     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]