From: simonpj <unknown>
Date: Wed, 24 Oct 2001 08:20:03 +0000 (+0000)
Subject: [project @ 2001-10-24 08:20:03 by simonpj]
X-Git-Tag: Approximately_9120_patches~730
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b692d4c0cbcc2cc95d4c0e20d0631ee479fd8d59;p=ghc-hetmet.git

[project @ 2001-10-24 08:20:03 by simonpj]
(DON'T MERGE)

Fix mkAtomicArgs so that it works.  It was greviously wrong,
leaving things like

	x = I# (negateInt# y)

without ANF-ing them.
---

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index fce552a..33400a1 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -349,7 +349,7 @@ completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
 
 	-- Make the arguments atomic if necessary, 
 	-- adding suitable bindings
-    addAtomicBindsE env aux_binds		$ \ env ->
+    addAtomicBindsE env (fromOL aux_binds)	$ \ env ->
     completeLazyBind env NotTopLevel
 		     old_bndr new_bndr rhs2	`thenSmpl` \ (floats, env) ->
     addFloats env floats thing_inside
@@ -466,7 +466,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
 
 	-- If the result is a PAP, float the floats out, else wrap them
 	-- By this time it's already been ANF-ised (if necessary)
-    if isEmptyFloats floats && null aux_binds then	-- Shortcut a common case
+    if isEmptyFloats floats && isNilOL aux_binds then	-- Shortcut a common case
 	completeLazyBind env1 top_lvl bndr bndr'' rhs2
 
 	-- We use exprIsTrivial here because we want to reveal lone variables.  
@@ -494,7 +494,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
 
 	tick LetFloatFromLet			`thenSmpl_` (
 	addFloats env1 floats			$ \ env2 ->
-	addAtomicBinds env2 aux_binds		$ \ env3 ->
+	addAtomicBinds env2 (fromOL aux_binds)	$ \ env3 ->
 	completeLazyBind env3 top_lvl bndr bndr'' rhs2)
 
     else
@@ -1097,57 +1097,43 @@ context information.
 mkAtomicArgs :: Bool	-- A strict binding
 	     -> Bool	-- OK to float unlifted args
 	     -> OutExpr
-	     -> SimplM ([(OutId,OutExpr)],	-- The floats (unusually) may include
-			OutExpr)		-- things that need case-binding,
-						-- if the strict-binding flag is on
+	     -> SimplM (OrdList (OutId,OutExpr),  -- The floats (unusually) may include
+			OutExpr)		  -- things that need case-binding,
+						  -- if the strict-binding flag is on
 
 mkAtomicArgs is_strict ok_float_unlifted rhs
-  = mk_atomic_args rhs		`thenSmpl` \ maybe_stuff ->
-    case maybe_stuff of
-	Nothing		      -> returnSmpl ([], 	      rhs) 
-	Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
+  | (Var fun, args) <- collectArgs rhs,			-- It's an application
+    isDataConId fun || valArgCount args < idArity fun	-- And it's a constructor or PAP
+  = go fun nilOL [] args	-- Have a go
+
+  | otherwise = bale_out	-- Give up
 
   where
-    mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
-	-- Nothing => no change
-    mk_atomic_args rhs
-      | (Var fun, args) <- collectArgs rhs,			-- It's an application
-        isDataConId fun || valArgCount args < idArity fun	-- And it's a constructor or PAP
-      = 	-- Worth a try
-        go nilOL [] args	`thenSmpl` \ maybe_stuff ->
-	case maybe_stuff of
-	  Nothing		  -> returnSmpl Nothing
-	  Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
-    
-     | otherwise
-     = returnSmpl Nothing
+    bale_out = returnSmpl (nilOL, rhs)
+
+    go fun binds rev_args [] 
+	= returnSmpl (binds, mkApps (Var fun) (reverse rev_args))
 
-    go binds rev_args [] 
-	= returnSmpl (Just (binds, reverse rev_args))
-    go binds rev_args (arg : args) 
-	|  exprIsTrivial arg 	-- Easy case
-	= go binds (arg:rev_args) args
+    go fun binds rev_args (arg : args) 
+	| exprIsTrivial arg 	-- Easy case
+	= go fun binds (arg:rev_args) args
 
 	| not can_float_arg	-- Can't make this arg atomic
-  	= returnSmpl Nothing	-- ... so give up
+  	= bale_out		-- ... so give up
 
 	| otherwise	-- Don't forget to do it recursively
 			-- E.g.  x = a:b:c:[]
-	=  mk_atomic_args arg					`thenSmpl` \ maybe_anf ->
-	   case maybe_anf of {
-	     Nothing -> returnSmpl Nothing ;
-	     Just (arg_binds,arg') ->
-
-	   newId SLIT("a") arg_ty				`thenSmpl` \ arg_id ->
-	   go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) 
+	=  mkAtomicArgs is_strict ok_float_unlifted arg	`thenSmpl` \ (arg_binds, arg') ->
+	   newId SLIT("a") arg_ty			`thenSmpl` \ arg_id ->
+	   go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) 
 	      (Var arg_id : rev_args) args
-	   }
 	where
 	  arg_ty        = exprType arg
 	  can_float_arg =  is_strict 
 			|| not (isUnLiftedType arg_ty)
 			|| (ok_float_unlifted && exprOkForSpeculation arg)
 
+
 addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
 	       -> (SimplEnv -> SimplM (FloatsWith a))
 	       -> SimplM (FloatsWith a)