From: simonmar <unknown>
Date: Wed, 6 Dec 2000 14:25:13 +0000 (+0000)
Subject: [project @ 2000-12-06 14:25:13 by simonmar]
X-Git-Tag: Approximately_9120_patches~3195
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0fd1a29e1378753ac43e890669faf0580506bf3a;p=ghc-hetmet.git

[project @ 2000-12-06 14:25:13 by simonmar]
Reinstate the gruesome hack that makes seq work.
---

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
 -- -----------------------------------------------------------------------------
 
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 130a8f8..c9d9b63 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -362,7 +362,7 @@ coreToStgExpr (Case scrut bndr alts)
 	live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
     in
     returnLne (
-      StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
+      mkStgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
       (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
       (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
 		-- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
@@ -428,21 +428,6 @@ coreToStgExpr (Case scrut bndr alts)
      	   = coreToStgExpr rhs	`thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
      	     returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
 
-	mkStgAlgAlts ty alts deflt
-	 =  case alts of
-			-- Get the tycon from the data con
-		(dc, _, _, _) : _rest
-		    -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
-	
-			-- Otherwise just do your best
-		[] -> case splitTyConApp_maybe (repType ty) of
-			Just (tc,_) | isAlgTyCon tc 
-				-> StgAlgAlts (Just tc) alts deflt
-			other
-				-> StgAlgAlts Nothing alts deflt
-	
-	mkStgPrimAlts ty alts deflt 
-	  = StgPrimAlts (tyConAppTyCon ty) alts deflt
 \end{code}
 
 Lets not only take quite a bit of work, but this is where we convert
@@ -472,6 +457,55 @@ isForeignObjPrimTy ty
 	Nothing		-> False
 \end{code}
 
+\begin{code}
+mkStgCase scrut@(StgPrimApp ParOp _ _) lvs1 lvs2 bndr srt
+	  (StgPrimAlts tycon _ deflt@(StgBindDefault _))
+  = StgCase scrut lvs1 lvs2 bndr srt (StgPrimAlts tycon [] deflt)
+
+mkStgCase (StgPrimApp SeqOp [scrut] _) lvs1 lvs2 bndr srt
+	  (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
+  = StgCase scrut_expr lvs1 lvs2 new_bndr srt 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 lvs1 lvs2 bndr srt alts
+    = StgCase scrut lvs1 lvs2 bndr srt alts
+
+
+mkStgAlgAlts ty alts deflt
+ =  case alts of
+		-- Get the tycon from the data con
+	(dc, _, _, _) : _rest
+	    -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+		-- Otherwise just do your best
+	[] -> case splitTyConApp_maybe (repType ty) of
+		Just (tc,_) | isAlgTyCon tc 
+			-> StgAlgAlts (Just tc) alts deflt
+		other
+			-> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt 
+  = StgPrimAlts (tyConAppTyCon ty) alts deflt
+\end{code}
+
 
 Applications:
 \begin{code}