X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;fp=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=20e47d7c6f70190a1d2fc45089818bd043a9db77;hb=a4ac14369fc0c456b3add10e63a21a3d45f68dda;hp=6e109c8c255373373dadbb39e71aed4cbbec5410;hpb=11fcbaeb156ebb1a89cd5e05960c599d8dcf5924;p=ghc-hetmet.git

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}