Allow C argument regs to be used as global regs (R1, R2, etc.)

The problem here was that we generated C calls with expressions
involving R1 etc. as parameters.  When some of the R registers are
also C argument registers, both GCC and the native code generator
generate incorrect code.  The hacky workaround is to assign
problematic arguments to temporaries first; fortunately this works
with both GCC and the NCG, but we have to be careful not to undo this
with later optimisations (see changes to CmmOpt).

2 files changed, 78 insertions, 44 deletions

diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs
index e56189ae11..10f41bdf8b 100644
--- a/ghc/compiler/codeGen/CgForeignCall.hs
+++ b/ghc/compiler/codeGen/CgForeignCall.hs
@@ -7,8 +7,9 @@
 -----------------------------------------------------------------------------
 
 module CgForeignCall (
-  emitForeignCall,
   cgForeignCall,
+  emitForeignCall,
+  emitForeignCall',
   shimForeignCallArg,
   emitSaveThreadState, -- will be needed by the Cmm parser
   emitLoadThreadState, -- ditto
@@ -22,7 +23,8 @@ import StgSyn		( StgLiveVars, StgArg, stgArgType )
 import CgProf		( curCCS, curCCSAddr )
 import CgBindery	( getVolatileRegs, getArgAmodes )
 import CgMonad
-import CgUtils		( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp )
+import CgUtils		( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp,
+			  assignTemp )
 import Type		( tyConAppTyCon, repType )
 import TysPrim
 import CLabel		( mkForeignLabel, mkRtsCodeLabel )
@@ -68,32 +70,9 @@ emitForeignCall
 	-> Code
 
 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
-  | not (playSafe safety) 
-  = do 
-    vols <- getVolatileRegs live
-    stmtC (the_call vols)
-  
-  | otherwise -- it's a safe foreign call
-  = do
-    vols <- getVolatileRegs live
-    id <- newTemp wordRep
-    emitSaveThreadState
-    stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) 
-			[(id,PtrHint)]
-			[ (CmmReg (CmmGlobal BaseReg), PtrHint) ] 
-			(Just vols)
-			)
-    stmtC (the_call vols)
-    stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) 
-			[ (CmmGlobal BaseReg, PtrHint) ]
-				-- Assign the result to BaseReg: we
-				-- might now have a different
-				-- Capability!
-			[ (CmmReg id, PtrHint) ]
-			(Just vols)
-			)
-    emitLoadThreadState
-
+  = do vols <- getVolatileRegs live
+       emitForeignCall' safety results
+		(CmmForeignCall cmm_target cconv) call_args (Just vols)
   where
       (call_args, cmm_target)
 	= case target of
@@ -101,9 +80,6 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
 					(mkForeignLabel lbl call_size False)))
 	   DynamicTarget    ->  case args of (fn,_):rest -> (rest, fn)
 
-      the_call vols = CmmCall (CmmForeignCall cmm_target cconv) 
-			  results call_args (Just vols)
-
 	-- in the stdcall calling convention, the symbol needs @size appended
 	-- to it, where size is the total number of bytes of arguments.  We
 	-- attach this info to the CLabel here, and the CLabel pretty printer
@@ -115,13 +91,66 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
 	-- ToDo: this might not be correct for 64-bit API
       arg_size rep = max (machRepByteWidth rep) wORD_SIZE
 
-
 emitForeignCall results (DNCall _) args live
   = panic "emitForeignCall: DNCall"
 
+
+-- alternative entry point, used by CmmParse
+emitForeignCall'
+	:: Safety
+	-> [(CmmReg,MachHint)]	-- where to put the results
+	-> CmmCallTarget	-- the op
+	-> [(CmmExpr,MachHint)] -- arguments
+	-> Maybe [GlobalReg]	-- live vars, in case we need to save them
+	-> Code
+emitForeignCall' safety results target args vols 
+  | not (playSafe safety) = do
+    temp_args <- load_args_into_temps args
+    stmtC (CmmCall target results temp_args vols)
+
+  | otherwise = do
+    id <- newTemp wordRep
+    temp_args <- load_args_into_temps args
+    emitSaveThreadState
+    stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) 
+			[(id,PtrHint)]
+			[ (CmmReg (CmmGlobal BaseReg), PtrHint) ] 
+			vols
+			)
+    stmtC (CmmCall target results temp_args vols)
+    stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) 
+			[ (CmmGlobal BaseReg, PtrHint) ]
+				-- Assign the result to BaseReg: we
+				-- might now have a different
+				-- Capability!
+			[ (CmmReg id, PtrHint) ]
+			vols
+			)
+    emitLoadThreadState
+
+
 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 
+
+-- we might need to load arguments into temporaries before
+-- making the call, because certain global registers might
+-- overlap with registers that the C calling convention uses
+-- for passing arguments.
+--
+-- This is a HACK; really it should be done in the back end, but
+-- it's easier to generate the temporaries here.
+load_args_into_temps args = mapM maybe_assignTemp args
+	
+maybe_assignTemp (e, hint)
+  | hasNoGlobalRegs e = return (e, hint)
+  | otherwise          = do 
+	-- don't use assignTemp, it uses its own notion of "trivial"
+	-- expressions, which are wrong here
+	reg <- newTemp (cmmExprRep e)
+	stmtC (CmmAssign reg e)
+	return (CmmReg reg, hint)
+
 -- -----------------------------------------------------------------------------
 -- Save/restore the thread state in the TSO
 
diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs
index c1264be62f..bc7c9140ed 100644
--- a/ghc/compiler/codeGen/CgPrimOp.hs
+++ b/ghc/compiler/codeGen/CgPrimOp.hs
@@ -14,6 +14,7 @@ module CgPrimOp (
 
 import ForeignCall	( CCallConv(CCallConv) )
 import StgSyn		( StgLiveVars, StgArg )
+import CgForeignCall	( emitForeignCall' )
 import CgBindery	( getVolatileRegs, getArgAmodes )
 import CgMonad
 import CgInfoTbls	( getConstrTag )
@@ -117,10 +118,11 @@ emitPrimOp [res] ParOp [arg] live
 	-- for now, just implement this in a C function
 	-- later, we might want to inline it.
     vols <- getVolatileRegs live
-    stmtC (CmmCall (CmmForeignCall newspark CCallConv) [(res,NoHint)]
-		[(CmmReg (CmmGlobal BaseReg), PtrHint), 
-		 (arg,PtrHint)] 
-		(Just vols))
+    emitForeignCall' PlayRisky
+	[(res,NoHint)]
+    	(CmmForeignCall newspark CCallConv) 
+	[(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)] 
+	(Just vols)
   where
 	newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
 
@@ -131,12 +133,12 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live
    = do
 	stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
 	vols <- getVolatileRegs live
-	stmtC (CmmCall (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
-				CCallConv) 
-			[{-no results-}]
-			[(CmmReg (CmmGlobal BaseReg), PtrHint),
-			 (mutv,PtrHint)]
-			(Just vols))
+	emitForeignCall' PlayRisky
+		[{-no results-}]
+		(CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+			 CCallConv)
+		[(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
+		(Just vols)
 
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
@@ -336,8 +338,11 @@ emitPrimOp [res] op [arg] live
 emitPrimOp [res] op args live
    | Just prim <- callishOp op
    = do vols <- getVolatileRegs live
-	stmtC (CmmCall (CmmPrim prim) [(res,NoHint)] 
-		[(a,NoHint) | a<-args] (Just vols)) -- ToDo: hints?
+	emitForeignCall' PlayRisky
+	   [(res,NoHint)] 
+	   (CmmPrim prim) 
+	   [(a,NoHint) | a<-args]  -- ToDo: hints?
+	   (Just vols)
 
    | Just mop <- translateOp op
    = let stmt = CmmAssign res (CmmMachOp mop args) in