From: simonmar <unknown>
Date: Tue, 20 Aug 2002 10:32:48 +0000 (+0000)
Subject: [project @ 2002-08-20 10:32:48 by simonmar]
X-Git-Tag: Approx_11550_changesets_converted~1758
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a4ac14369fc0c456b3add10e63a21a3d45f68dda;p=ghc-hetmet.git

[project @ 2002-08-20 10:32:48 by simonmar]
Fix a buglet in CorePrep:  an expression such as

	case __coerce (\x -> e) :: T of { ... }

would be left as is, but the lambda expression should really be
abstracted as a let (causes a panic later in srtExpr; shown up by
the dynamic001 test).  There was a missing call to deLam in the case
for Case expressions in corePrepExprFloat.

In addition, I made a new version of deLam, deLamFloat, which can
float any bindings generated.  This helps to generate slightly cleaner
code in the above case (the binding is floated out of the scrutinee).

Also: GC unused imports while I'm here.
---

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 6e109c8..20e47d7 100644
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -15,14 +15,13 @@ import CoreFVs	( exprFreeVars )
 import CoreLint	( endPass )
 import CoreSyn
 import Type	( Type, applyTy, splitFunTy_maybe, 
-		  isUnLiftedType, isUnboxedTupleType, repType, seqType )
+		  isUnLiftedType, isUnboxedTupleType, seqType )
 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
-import PrimOp	( PrimOp(..) )
 import Var 	( Var, Id, setVarUnique )
 import VarSet
 import VarEnv
 import Id	( mkSysLocal, idType, idNewDemandInfo, idArity,
-		  setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, 
+		  isFCallId, isGlobalId, 
 		  isLocalId, hasNoBinding, idNewStrictness, 
 		  isDataConId_maybe, idUnfolding
 		)
@@ -341,8 +340,8 @@ corePrepExprFloat env (Let bind body)
 
 corePrepExprFloat env (Note n@(SCC _) expr)
   = corePrepAnExpr env expr		`thenUs` \ expr1 ->
-    deLam expr1				`thenUs` \ expr2 ->
-    returnUs (nilOL, Note n expr2)
+    deLamFloat expr1			`thenUs` \ (floats, expr2) ->
+    returnUs (floats, Note n expr2)
 
 corePrepExprFloat env (Note other_note expr)
   = corePrepExprFloat env expr		`thenUs` \ (floats, expr') ->
@@ -356,10 +355,11 @@ corePrepExprFloat env expr@(Lam _ _)
     (bndrs,body) = collectBinders expr
 
 corePrepExprFloat env (Case scrut bndr alts)
-  = corePrepExprFloat env scrut		`thenUs` \ (floats, scrut') ->
+  = corePrepExprFloat env scrut		`thenUs` \ (floats1, scrut1) ->
+    deLamFloat scrut1			`thenUs` \ (floats2, scrut2) ->
     cloneBndr env bndr			`thenUs` \ (env', bndr') ->
     mapUs (sat_alt env') alts		`thenUs` \ alts' ->
-    returnUs (floats, Case scrut' bndr' alts')
+    returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts')
   where
     sat_alt env (con, bs, rhs)
 	  = cloneBndrs env bs		`thenUs` \ (env', bs') ->
@@ -524,7 +524,7 @@ mkLocalNonRec bndr dem floats rhs
 
   where
     bndr_ty	 = idType bndr
-    bndr_rep_ty  = repType bndr_ty
+
 
 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 mkBinds binds body 
@@ -579,22 +579,29 @@ etaExpandRhs bndr rhs
 -- We arrange that they only show up as the RHS of a let(rec)
 -- ---------------------------------------------------------------------------
 
-deLam :: CoreExpr -> UniqSM CoreExpr	
+deLam :: CoreExpr -> UniqSM CoreExpr
+deLam expr = 
+  deLamFloat expr   `thenUs` \ (floats, expr) ->
+  mkBinds floats expr
+
+
+deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 -- Remove top level lambdas by let-bindinig
 
-deLam (Note n expr)
+deLamFloat (Note n expr)
   =	-- You can get things like
 	-- 	case e of { p -> coerce t (\s -> ...) }
-    deLam expr	`thenUs` \ expr' ->
-    returnUs (Note n expr')
+    deLamFloat expr	`thenUs` \ (floats, expr') ->
+    returnUs (floats, Note n expr')
 
-deLam expr 
-  | null bndrs = returnUs expr
+deLamFloat expr 
+  | null bndrs = returnUs (nilOL, expr)
   | otherwise 
   = case tryEta bndrs body of
-      Just no_lam_result -> returnUs no_lam_result
+      Just no_lam_result -> returnUs (nilOL, no_lam_result)
       Nothing	         -> newVar (exprType expr)	`thenUs` \ fn ->
-			    returnUs (Let (NonRec fn expr) (Var fn))
+			    returnUs (unitOL (FloatLet (NonRec fn expr)), 
+				      Var fn)
   where
     (bndrs,body) = collectBinders expr
 
@@ -656,8 +663,10 @@ bdrDem :: Id -> RhsDemand
 bdrDem id = mkDem (idNewDemandInfo id)
 		  False {- For now -}
 
-safeDem, onceDem :: RhsDemand
-safeDem = RhsDemand False False  -- always safe to use this
+-- safeDem :: RhsDemand
+-- safeDem = RhsDemand False False  -- always safe to use this
+
+onceDem :: RhsDemand
 onceDem = RhsDemand False True   -- used at most once
 \end{code}