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).

ghc/compiler/cmm/CmmOpt.hs

@@ -15,6 +15,7 @@ module CmmOpt (
 #include "HsVersions.h"
 
 import Cmm
+import CmmUtils	( hasNoGlobalRegs )
 import CLabel	( entryLblToInfoLbl )
 import MachOp
 import SMRep	( tablesNextToCode )
@@ -85,8 +86,17 @@ lookForInline u expr (CmmNop : rest)
 
 lookForInline u expr (stmt:stmts)
   = case lookupUFM (getStmtUses stmt) u of
-	Just 1 -> Just (inlineStmt u expr stmt : stmts)
+	Just 1 | ok_to_inline -> Just (inlineStmt u expr stmt : stmts)
 	_other -> Nothing
+  where
+	-- we don't inline into CmmCall if the expression refers to global
+	-- registers.  This is a HACK to avoid global registers clashing with
+	-- C argument-passing registers, really the back-end ought to be able
+	-- to handle it properly, but currently neither PprC nor the NCG can
+	-- do it.  See also CgForeignCall:load_args_into_temps.
+    ok_to_inline = case stmt of
+		     CmmCall{} -> hasNoGlobalRegs expr
+		     _ -> True
 
 -- -----------------------------------------------------------------------------
 -- Boring Cmm traversals for collecting usage info and substitutions.

ghc/compiler/cmm/CmmParse.y

@@ -32,7 +32,7 @@ import MachOp
 import SMRep		( fixedHdrSize, CgRep(..) )
 import Lexer
 
-import ForeignCall	( CCallConv(..) )
+import ForeignCall	( CCallConv(..), Safety(..) )
 import Literal		( mkMachInt )
 import Unique
 import UniqFM
@@ -732,7 +732,8 @@ foreignCall "C" results_code expr_code args_code vols
 	results <- sequence results_code
 	expr <- expr_code
 	args <- sequence args_code
-	stmtEC (CmmCall (CmmForeignCall expr CCallConv) results args vols)
+        code (emitForeignCall' PlayRisky results 
+                 (CmmForeignCall expr CCallConv) args vols)
 foreignCall conv _ _ _ _
   = fail ("unknown calling convention: " ++ conv)
 

ghc/compiler/cmm/CmmUtils.hs

@@ -10,7 +10,7 @@ module CmmUtils(
 	CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
 	isNopStmt,
 
-	isTrivialCmmExpr,
+	isTrivialCmmExpr, hasNoGlobalRegs,
 
 	cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex,
 	cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex,
@@ -90,6 +90,14 @@ isTrivialCmmExpr (CmmLit _)      = True
 isTrivialCmmExpr (CmmReg _)      = True
 isTrivialCmmExpr (CmmRegOff _ _) = True
 
+hasNoGlobalRegs :: CmmExpr -> Bool
+hasNoGlobalRegs (CmmLoad e _)   	   = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmMachOp _ es) 	   = all hasNoGlobalRegs es
+hasNoGlobalRegs (CmmLit _)      	   = True
+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
+hasNoGlobalRegs _ = False
+
 ---------------------------------------------------
 --
 --	Expr Construction helpers

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
 

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