X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCase.lhs;h=398441e30c67620cb936959dce8ff9f21c810c12;hp=abda4dda317a0d97de02acb4ecdc88c27728705b;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=2955dc83e4cce22ec0da7a2e654e2193814863cc

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index abda4dd..398441e 100644
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -4,6 +4,13 @@
 %
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CgCase (	cgCase, saveVolatileVarsAndRegs, 
 		restoreCurrentCostCentre
 	) where
@@ -95,7 +102,6 @@ cgCase	:: StgExpr
 	-> StgLiveVars
 	-> StgLiveVars
 	-> Id
-	-> SRT
 	-> AltType
 	-> [StgAlt]
 	-> Code
@@ -104,12 +110,12 @@ cgCase	:: StgExpr
 Special case #1: case of literal.
 
 \begin{code}
-cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt 
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr
        alt_type@(PrimAlt tycon) alts
   = do	{ tmp_reg <- bindNewToTemp bndr
 	; cm_lit <- cgLit lit
-	; stmtC (CmmAssign tmp_reg (CmmLit cm_lit))
-	; cgPrimAlts NoGC alt_type tmp_reg alts }
+	; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
+	; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
 \end{code}
 
 Special case #2: scrutinising a primitive-typed variable.	No
@@ -120,7 +126,7 @@ allocating more heap than strictly necessary, but it will sometimes
 eliminate a heap check altogether.
 
 \begin{code}
-cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr
        alt_type@(PrimAlt tycon) alts
   = do	{ -- Careful! we can't just bind the default binder to the same thing
 	  -- as the scrutinee, since it might be a stack location, and having
@@ -129,15 +135,15 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 	  v_info <- getCgIdInfo v
 	; amode <- idInfoToAmode v_info
 	; tmp_reg <- bindNewToTemp bndr
-	; stmtC (CmmAssign tmp_reg amode)
-	; cgPrimAlts NoGC alt_type tmp_reg alts }
+	; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
+	; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
 \end{code}
 
 Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}
 cgCase (StgOpApp op@(StgPrimOp primop) args _) 
-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts
   | not (primOpOutOfLine primop)
   = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
 \end{code}
@@ -152,7 +158,7 @@ right here, just like an inline primop.
 
 \begin{code}
 cgCase (StgOpApp op@(StgFCallOp fcall _) args _) 
-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts
   | unsafe_foreign_call
   = ASSERT( isSingleton alts )
     do	--  *must* be an unboxed tuple alt.
@@ -177,7 +183,7 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
 cgCase (StgApp fun args)
-	live_in_whole_case live_in_alts bndr srt alt_type alts
+	live_in_whole_case live_in_alts bndr alt_type alts
   = do	{ fun_info <- getCgIdInfo fun
 	; arg_amodes <- getArgAmodes args
 
@@ -195,7 +201,7 @@ cgCase (StgApp fun args)
 	    <- forkEval alts_eob_info 
 			(allocStackTop retAddrSizeW >> nopC)
 			(do { deAllocStackTop retAddrSizeW
-			    ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+			    ; cgEvalAlts maybe_cc_slot bndr alt_type alts })
 
 	; setEndOfBlockInfo scrut_eob_info
 			    (performTailCall fun_info arg_amodes save_assts) }
@@ -215,7 +221,7 @@ deAllocStackTop call is doing above.
 Finally, here is the general case.
 
 \begin{code}
-cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
+cgCase expr live_in_whole_case live_in_alts bndr alt_type alts
   = do	{	-- Figure out what volatile variables to save
 	  nukeDeadBindings live_in_whole_case
     
@@ -232,7 +238,7 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
 				; allocStackTop retAddrSizeW   -- space for retn address 
 				; nopC })
 			   (do	{ deAllocStackTop retAddrSizeW
-				; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+				; cgEvalAlts maybe_cc_slot bndr alt_type alts })
 
 	; setEndOfBlockInfo scrut_eob_info (cgExpr expr)
     }
@@ -285,7 +291,7 @@ cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
   = do	{ 	-- PRIMITIVE ALTS, with non-void result
 	  tmp_reg <- bindNewToTemp bndr
 	; cgPrimOp [tmp_reg] primop args live_in_alts
-	; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts }
+	; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }
 
 cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
   = ASSERT( isSingleton alts )
@@ -315,7 +321,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
 	; this_pkg <- getThisPackage
 	; whenC (not (isDeadBinder bndr))
 		(do { tmp_reg <- bindNewToTemp bndr
-		    ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) })
+		    ; stmtC (CmmAssign
+                             (CmmLocal tmp_reg)
+                             (tagToClosure tycon tag_amode)) })
 
 		-- Compile the alts
 	; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
@@ -332,9 +340,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
          (_,e) <- getArgAmode arg
 	 return e
     do_enum_primop primop
-      = do tmp <- newTemp wordRep
+      = do tmp <- newNonPtrTemp wordRep
 	   cgPrimOp [tmp] primop args live_in_alts
-    	   returnFC (CmmReg tmp)
+    	   returnFC (CmmReg (CmmLocal tmp))
 
 cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
   = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
@@ -353,14 +361,13 @@ is some evaluation to be done.
 \begin{code}
 cgEvalAlts :: Maybe VirtualSpOffset	-- Offset of cost-centre to be restored, if any
 	   -> Id
-	   -> SRT			-- SRT for the continuation
 	   -> AltType
 	   -> [StgAlt]
 	   -> FCode Sequel	-- Any addr modes inside are guaranteed
 				-- to be a label so that we can duplicate it 
 				-- without risk of duplicating code
 
-cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts
   = do	{ let   rep = tyConCgRep tycon
 		reg = dataReturnConvPrim rep	-- Bottom for voidRep
 
@@ -372,10 +379,10 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
 		; restoreCurrentCostCentre cc_slot True
 		; cgPrimAlts GCMayHappen alt_type reg alts }
 
-	; lbl <- emitReturnTarget (idName bndr) abs_c srt
+	; lbl <- emitReturnTarget (idName bndr) abs_c
 	; returnFC (CaseAlts lbl Nothing bndr) }
 
-cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
+cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]
   =	-- Unboxed tuple case
 	-- By now, the simplifier should have have turned it
 	-- into 	case e of (# a,b #) -> e
@@ -394,10 +401,10 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
 			-- and finally the code for the alternative
 		; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
 				     (cgExpr rhs) }
-	; lbl <- emitReturnTarget (idName bndr) abs_c srt
+	; lbl <- emitReturnTarget (idName bndr) abs_c
 	; returnFC (CaseAlts lbl Nothing bndr) }
 
-cgEvalAlts cc_slot bndr srt alt_type alts
+cgEvalAlts cc_slot bndr alt_type alts
   = 	-- Algebraic and polymorphic case
     do	{	-- Bind the default binder
 	  bindNewToReg bndr nodeReg (mkLFArgument bndr)
@@ -414,7 +421,7 @@ cgEvalAlts cc_slot bndr srt alt_type alts
 	; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
 
 	; (lbl, branches) <- emitAlgReturnTarget (idName bndr) 
-				alts mb_deflt srt fam_sz
+				alts mb_deflt fam_sz
 
 	; returnFC (CaseAlts lbl branches bndr) }
   where