From: simonmar <unknown>
Date: Fri, 5 Jan 2001 16:06:01 +0000 (+0000)
Subject: [project @ 2001-01-05 16:06:01 by simonmar]
X-Git-Tag: Approximately_9120_patches~2963
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=372893551628ae83ebf9a40ff2e8ed39012a9271;p=ghc-hetmet.git

[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.
---

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