From eba4dfc2e9cf3caae2cdb6e54558972745a121f7 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 16 Aug 2006 10:48:31 +0000
Subject: [PATCH] Don't build unnecessary lets in knownCon

Faced with
	case x of y { (a,b) -> rhs }

where x is bound to (c,d), we were generating

	let y = (c,d) in rhs

and thenn hoping to get rid of the y binding by CSE or some such.  It's
better simply not to build it in the first place, by generating

	let y = x in rhs

This patch does the job.
---
 compiler/simplCore/Simplify.lhs |   36 +++++++++++++++++++++---------------
 1 file changed, 21 insertions(+), 15 deletions(-)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 53d0fd4..2003c08 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1273,11 +1273,11 @@ rebuildCase env scrut case_bndr alts cont
   | Just (con,args) <- exprIsConApp_maybe scrut	
 	-- Works when the scrutinee is a variable with a known unfolding
 	-- as well as when it's an explicit constructor application
-  = knownCon env (DataAlt con) args case_bndr alts cont
+  = knownCon env scrut (DataAlt con) args case_bndr alts cont
 
   | Lit lit <- scrut	-- No need for same treatment as constructors
 			-- because literals are inlined more vigorously
-  = knownCon env (LitAlt lit) [] case_bndr alts cont
+  = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
 
   | otherwise
   = 	-- Prepare the continuation;
@@ -1707,37 +1707,43 @@ and then
 All this should happen in one sweep.
 
 \begin{code}
-knownCon :: SimplEnv -> AltCon -> [OutExpr]
+knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
 	 -> InId -> [InAlt] -> SimplCont
 	 -> SimplM FloatsWithExpr
 
-knownCon env con args bndr alts cont
-  = tick (KnownBranch bndr)	`thenSmpl_`
+knownCon env scrut con args bndr alts cont
+  = tick (KnownBranch bndr)		`thenSmpl_`
     case findAlt con alts of
 	(DEFAULT, bs, rhs)     -> ASSERT( null bs )
 				  simplNonRecX env bndr scrut	$ \ env ->
-					-- This might give rise to a binding with non-atomic args
-					-- like x = Node (f x) (g x)
-					-- but no harm will be done
+				-- This might give rise to a binding with non-atomic args
+				-- like x = Node (f x) (g x)
+				-- but simplNonRecX will atomic-ify it
 				  simplExprF env rhs cont
-				where
-				  scrut = case con of
-					    LitAlt lit -> Lit lit
-					    DataAlt dc -> mkConApp dc args
 
 	(LitAlt lit, bs, rhs) ->  ASSERT( null bs )
-				  simplNonRecX env bndr (Lit lit)	$ \ env ->
+				  simplNonRecX env bndr scrut	$ \ env ->
 				  simplExprF env rhs cont
 
 	(DataAlt dc, bs, rhs)  
 		-> ASSERT( n_drop_tys + length bs == length args )
 		   bind_args env bs (drop n_drop_tys args)	$ \ env ->
 		   let
-			con_app  = mkConApp dc (take n_drop_tys args ++ con_args)
+			-- It's useful to bind bndr to scrut, rather than to a fresh
+			-- binding 	x = Con arg1 .. argn
+			-- because very often the scrut is a variable, so we avoid
+			-- creating, and then subsequently eliminating, a let-binding
+			-- BUT, if scrut is a not a variable, we must be careful
+			-- about duplicating the arg redexes; in that case, make
+			-- a new con-app from the args
+			bndr_rhs  = case scrut of
+					Var v -> scrut
+					other -> con_app
+			con_app = mkConApp dc (take n_drop_tys args ++ con_args)
 			con_args = [substExpr env (varToCoreExpr b) | b <- bs]
 					-- args are aready OutExprs, but bs are InIds
 		   in
-		   simplNonRecX env bndr con_app		$ \ env ->
+		   simplNonRecX env bndr bndr_rhs		$ \ env ->
 		   simplExprF env rhs cont
 	        where
 		   n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc)
-- 
1.7.10.4