From 372893551628ae83ebf9a40ff2e8ed39012a9271 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Fri, 5 Jan 2001 16:06:01 +0000
Subject: [PATCH] [project @ 2001-01-05 16:06:01 by simonmar] Add some
 constraints to the tryRhsTyLam transformation to prevent it
 floating out expressions of unlifted type.

---
 ghc/compiler/simplCore/SimplUtils.lhs |   11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index dd1f86a..5f8c77f 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -536,8 +536,8 @@ as we would normally do.
 tryRhsTyLam :: OutExpr -> SimplM ([OutBind], OutExpr)
 
 tryRhsTyLam rhs 			-- Only does something if there's a let
-  | null tyvars || not (worth_it body)	-- inside a type lambda, and a WHNF inside that
-  = returnSmpl ([], rhs)
+  | null tyvars || not (worth_it body)	-- inside a type lambda, 
+  = returnSmpl ([], rhs)		-- and a WHNF inside that
 
   | otherwise
   = go (\x -> x) body		`thenSmpl` \ (binds, body') ->
@@ -546,8 +546,11 @@ tryRhsTyLam rhs 			-- Only does something if there's a let
   where
     (tyvars, body) = collectTyBinders rhs
 
-    worth_it (Let _ e)	     = whnf_in_middle e
-    worth_it other     	     = False
+    worth_it (Let (NonRec x rhs) e) | isUnLiftedType (exprType rhs) = False
+    worth_it (Let _ e) = whnf_in_middle e
+    worth_it other     = False
+
+    whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (exprType rhs) = False
     whnf_in_middle (Let _ e) = whnf_in_middle e
     whnf_in_middle e	     = exprIsCheap e
 
-- 
1.7.10.4