From 46d88d870471379348f5661a56dad6ce4d7f5588 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 9 Aug 2004 13:19:29 +0000
Subject: [PATCH] [project @ 2004-08-09 13:19:29 by simonmar] Allow
 case-of-unsafe-ccall to compile to straight-line code, like
 it used to.  This has already been fixed on the
 backend-hacking-branch, but I'm doing it here so that it
 can be merged into the STABLE branch, where it will help to
 work around a bug.

The bug is in CgExpr.lhs:primRetUnboxedTuple, which picks temporaries
to assign the result of a ccall to.  The Cg monad doesn't have a uniq
supply (in the HEAD), so we always pick the same temporaries.  This
leads to clashes in complex function with multiple ccalls.  Again,
this is already fixed in the backend-hacking-branch.  I don't see an
easy fix for this bug.

The compilation of case-of-unsafe-ccall doesn't suffer from this
problem, and it will help work around some cases of the bug, so I'm
going to merge this onto the STABLE branch after some testing.
---
 ghc/compiler/codeGen/CgCase.lhs |   60 +++++++++++++++++++++++----------------
 1 file changed, 36 insertions(+), 24 deletions(-)

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index af053f6..d313839 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.66 2003/07/22 16:11:26 simonmar Exp $
+% $Id: CgCase.lhs,v 1.67 2004/08/09 13:19:29 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -53,6 +53,7 @@ import PrimRep		( getPrimRepSize, retPrimRepSize, PrimRep(..)
 			)
 import TyCon		( TyCon, isEnumerationTyCon, tyConPrimRep	)
 import Unique           ( Unique, Uniquable(..), newTagUnique )
+import ForeignCall
 import Util		( only )
 import List		( sortBy )
 import Outputable
@@ -145,14 +146,14 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
     bindNewToTemp bndr			`thenFC` \ tmp_amode ->
     absC (CAssign tmp_amode amode)	`thenC`
     cgPrimAlts NoGC tmp_amode alts alt_type
-\end{code}	
+\end{code}
 
-Special case #3: inline PrimOps.
+Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}
-cgCase (StgOpApp op@(StgPrimOp primop) args _) 
+cgCase (StgOpApp op args _) 
        live_in_whole_case live_in_alts bndr srt alt_type alts
-  | not (primOpOutOfLine primop)
+  | inline_primop
   =	-- Get amodes for the arguments and results
     getArgAmodes args			`thenFC` \ arg_amodes ->
     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
@@ -175,7 +176,30 @@ cgCase (StgOpApp op@(StgPrimOp primop) args _)
 	   [(_, res_ids, _, rhs)] = alts
 
       AlgAlt tycon 	-- ENUMERATION TYPE RETURN
+        | StgPrimOp primop <- op
 	-> ASSERT( isEnumerationTyCon tycon )
+	   let
+	     do_enum_primop :: PrimOp -> FCode CAddrMode	-- Returns amode for result
+	     do_enum_primop TagToEnumOp	-- No code!
+	        = returnFC (only arg_amodes)
+	     
+	     do_enum_primop primop
+	      = absC (COpStmt [tag_amode] op arg_amodes vol_regs)	`thenC`
+		returnFC tag_amode
+	      where			
+		tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+			-- Being a bit short of uniques for temporary
+			-- variables here, we use newTagUnique to
+			-- generate a new unique from the case binder.
+			-- The case binder's unique will presumably
+			-- have the 'c' tag (generated by CoreToStg),
+			-- so we just change its tag to 'C' (for
+			-- 'case') to ensure it doesn't clash with
+			-- anything else.  We can't use the unique
+			-- from the case binder, becaus e this is used
+			-- to hold the actual result closure (via the
+			-- call to bindNewToTemp)
+	   in
 	   do_enum_primop primop		`thenFC` \ tag_amode ->
 
 	 	-- Bind the default binder if necessary
@@ -194,27 +218,15 @@ cgCase (StgOpApp op@(StgPrimOp primop) args _)
 
 		-- Do the switch
 	   absC (mkAlgAltsCSwitch tag_amode tagged_alts)
-	where
-	   do_enum_primop :: PrimOp -> FCode CAddrMode	-- Returns amode for result
-	   do_enum_primop TagToEnumOp	-- No code!
-	      = returnFC (only arg_amodes)
-
-	   do_enum_primop primop
- 	      = absC (COpStmt [tag_amode] op arg_amodes vol_regs)	`thenC`
-		returnFC tag_amode
-	      where			
-		tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
-			-- Being a bit short of uniques for temporary variables here, 
-			-- we use newTagUnique to generate a new unique from the case 
-			-- binder.  The case binder's unique will presumably have 
-			-- the 'c' tag (generated by CoreToStg), so we just change 
-			-- its tag to 'C' (for 'case') to ensure it doesn't clash with 
-			-- anything else.
-			-- We can't use the unique from the case binder, becaus e
-			-- this is used to hold the actual result closure
-			-- (via the call to bindNewToTemp)
 
       other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
+  where
+   inline_primop = case op of
+	StgPrimOp primop  -> not (primOpOutOfLine primop)
+	StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
+		 -- unsafe foreign calls are "inline"
+	_otherwise -> False
+
 \end{code}
 
 TODO: Case-of-case of primop can probably be done inline too (but
-- 
1.7.10.4