From a84a227cee9e87b4fa872366a4ac3ae0eeda16ef Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Thu, 5 Oct 2006 16:18:19 +0000
Subject: [PATCH] Correct the float-coercions-out-of-let patch

---
 compiler/coreSyn/CoreSyn.lhs    |    3 ---
 compiler/simplCore/Simplify.lhs |    7 +++++++
 2 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 65ad53c..65a1b40 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -604,7 +604,6 @@ seqExpr (Lit lit)       = lit `seq` ()
 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
--- gaw 2004
 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
@@ -652,7 +651,6 @@ data AnnExpr' bndr annot
   | AnnLit	Literal
   | AnnLam	bndr (AnnExpr bndr annot)
   | AnnApp	(AnnExpr bndr annot) (AnnExpr bndr annot)
--- gaw 2004
   | AnnCase	(AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
   | AnnLet	(AnnBind bndr annot) (AnnExpr bndr annot)
   | AnnCast     (AnnExpr bndr annot) Coercion
@@ -684,7 +682,6 @@ deAnnotate' (AnnLet bind body)
     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
--- gaw 2004
 deAnnotate' (AnnCase scrut v t alts)
   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 404a77f..db08df6 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1195,7 +1195,9 @@ mkAtomicArgsE :: SimplEnv
 	      -> SimplM FloatsWithExpr
 
 mkAtomicArgsE env is_strict (Cast rhs co) thing_inside
+  | not (exprIsTrivial rhs)
 	-- Note [Float coersions]
+	-- See also Note [Take care] below
   = do	{ id <- newId FSLIT("a") (exprType rhs)
 	; completeNonRecX env False id id rhs $ \ env ->
 	  thing_inside env (Cast (Var id) co) }
@@ -1219,6 +1221,10 @@ mkAtomicArgsE env is_strict rhs thing_inside
 	= do { arg_id <- newId FSLIT("a") arg_ty
 	     ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
 	       go env (App fun (Var arg_id)) args }
+		-- Note [Take care]:
+		-- This is sightly delicate.  If completeNonRecX was to do a postInlineUnconditionally
+		-- (undoing the effect of introducing the let-binding), we'd find arg_id had
+		-- no binding.   The exprIsTrivial is the only time that'll happen, though.
 	where
 	  arg_ty = exprType arg
 	  no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
@@ -1233,6 +1239,7 @@ mkAtomicArgs :: Bool	-- OK to float unlifted args
 						  -- if the strict-binding flag is on
 
 mkAtomicArgs ok_float_unlifted (Cast rhs co)
+  | not (exprIsTrivial rhs)
 	-- Note [Float coersions]
   = do	{ id <- newId FSLIT("a") (exprType rhs)
 	; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs
-- 
1.7.10.4