X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSat.lhs;h=900f24f8fca6babe144e43165ae747f32fe5164a;hb=0fd1a29e1378753ac43e890669faf0580506bf3a;hp=f512d8c9c108b3770326a1d93ad6dde8137d374a;hpb=d364541154457a49e3c35d671d7a1b57c9c4cca3;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs
index f512d8c..900f24f 100644
--- a/ghc/compiler/coreSyn/CoreSat.lhs
+++ b/ghc/compiler/coreSyn/CoreSat.lhs
@@ -28,9 +28,9 @@ import CmdLineOpts
 import Outputable
 \end{code}
 
------------------------------------------------------------------------------
-Overview
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
+-- Overview
+-- ---------------------------------------------------------------------------
 
 Most of the contents of this pass used to be in CoreToStg.  The
 primary goals here are:
@@ -186,8 +186,7 @@ coreSatExprFloat (Lam v e)
 coreSatExprFloat (Case scrut bndr alts)
   = coreSatExprFloat scrut		`thenUs` \ (floats, scrut) ->
     mapUs sat_alt alts			`thenUs` \ alts ->
-    mkCase scrut bndr alts		`thenUs` \ expr ->
-    returnUs (floats, expr)
+    returnUs (floats, Case scrut bndr alts)
   where
     sat_alt (con, bs, rhs)
 	  = coreSatAnExpr rhs	  	 `thenUs` \ rhs ->
@@ -425,8 +424,7 @@ mk_let bndr rhs dem floats body
 #endif
   | isUnLiftedType bndr_rep_ty
   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
-    mkCase rhs bndr [(DEFAULT, [], body)]  `thenUs` \ expr' ->
-    mkBinds floats expr'
+    mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
 
   | is_whnf
   = if is_strict then
@@ -445,8 +443,7 @@ mk_let bndr rhs dem floats body
   | otherwise 	-- Not WHNF
   = if is_strict then
 	-- Strict let with non-WHNF rhs
-	mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
-	mkBinds floats expr'
+	mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
     else
 	-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 	mkBinds floats rhs		`thenUs` \ new_rhs ->
@@ -466,56 +463,6 @@ splitFloats (f : fs) = case splitFloats fs of
 splitFloats [] = ([], [])
 
 -- -----------------------------------------------------------------------------
--- Making case expressions
--- -----------------------------------------------------------------------------
-
-mkCase scrut bndr alts = returnUs (Case scrut bndr alts) -- ToDo
-
-{-
-mkCase scrut@(App _ _) bndr alts
-  = let (f,args) = collectArgs scrut in
-    
-	
-
-mkCase scrut@(StgPrimApp ParOp _ _) bndr
-	  (StgPrimAlts tycon _ deflt@(StgBindDefault _))
-  = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
-
-mkStgCase (StgPrimApp SeqOp [scrut] _) bndr 
-	  (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
-  = mkStgCase scrut_expr new_bndr new_alts
-  where
-    new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
-	     | otherwise	       = mkStgAlgAlts scrut_ty [] deflt
-    scrut_ty = stgArgType scrut
-    new_bndr = setIdType bndr scrut_ty
-	-- NB:  SeqOp :: forall a. a -> Int#
-	-- So bndr has type Int# 
-	-- But now we are going to scrutinise the SeqOp's argument directly,
-	-- so we must change the type of the case binder to match that
-	-- of the argument expression e.
-
-    scrut_expr = case scrut of
-		   StgVarArg v -> StgApp v []
-		   -- Others should not happen because 
-		   -- seq of a value should have disappeared
-		   StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
-
-mkStgCase scrut bndr alts
-  = deStgLam scrut	`thenUs` \ scrut' ->
-	-- It is (just) possible to get a lambda as a srutinee here
-	-- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
-	-- gives:	case ...Bool == Int->Int... of
-	--		   True -> case coerce Bool (\x -> + 1 x) of
-	--				True -> ...
-	--				False -> ...
-	--		   False -> ...
-	-- The True branch of the outer case will never happen, of course.
-
-    returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
--}
-
--------------------------------------------------------------------------
 -- Demands
 -- -----------------------------------------------------------------------------