X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgForeignCall.hs;h=10f41bdf8bc1ae70297d96c8b322daba4545d8d9;hb=370848f10c0b4aa9faabcd28e090b0a1e9ad9fd6;hp=572a3876f56524edd77f4790f8db4e71cc9f662e;hpb=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs
index 572a387..10f41bd 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,26 +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,NoHint)]
-			[ (CmmReg (CmmGlobal BaseReg), NoHint) ] 
-			Nothing{-save all; ToDo-}
-			)
-    stmtC (the_call vols)
-    stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) []
-			[ (CmmReg id, NoHint) ] (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
@@ -95,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
@@ -109,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
 
@@ -204,15 +239,11 @@ currentNursery 	  = CmmGlobal CurrentNursery
 
 -- -----------------------------------------------------------------------------
 -- For certain types passed to foreign calls, we adjust the actual
--- value passed to the call.  Two main cases: for ForeignObj# we pass
--- the pointer inside the ForeignObj# closure, and for ByteArray#/Array# we
--- pass the address of the actual array, not the address of the heap object.
+-- value passed to the call.  For ByteArray#/Array# we pass the
+-- address of the actual array, not the address of the heap object.
 
 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 shimForeignCallArg arg expr
-  | tycon == foreignObjPrimTyCon
-	= cmmLoadIndexW expr fixedHdrSize
-
   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 	= cmmOffsetB expr arrPtrsHdrSize