[project @ 2005-10-27 00:21:24 by sof]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgForeignCall.hs

diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs
index 9a8ef9e..155e302 100644 (file)
--- a/ghc/compiler/codeGen/CgForeignCall.hs
+++ b/ghc/compiler/codeGen/CgForeignCall.hs
@@ -32,7 +32,7 @@ import MachOp
 import SMRep
 import ForeignCall
 import Constants
-import CmdLineOpts     ( opt_SccProfilingOn )
+import StaticFlags     ( opt_SccProfilingOn, opt_SMP )
 import Outputable
 
 import Monad           ( when )
@@ -78,13 +78,20 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
     vols <- getVolatileRegs live
     id <- newTemp wordRep
     emitSaveThreadState
-    stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) [(id,NoHint)]
-                       [ (CmmReg (CmmGlobal BaseReg), NoHint) ] 
-                       Nothing{-save all; ToDo-}
+    stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) 
+                       [(id,PtrHint)]
+                       [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] 
+                       (Just vols)
                        )
     stmtC (the_call vols)
-    stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) []
-                       [ (CmmReg id, NoHint) ] (Just vols)
+    stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) 
+                       (if opt_SMP then [(CmmGlobal BaseReg, PtrHint)] else [])
+                               -- Assign the result to BaseReg: we might now have
+                               -- a different Capability!  Small optimisation:
+                               -- only do this in SMP mode, where there are >1
+                               -- Capabilities.
+                       [ (CmmReg id, PtrHint) ]
+                       (Just vols)
                        )
     emitLoadThreadState
 
@@ -92,14 +99,23 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
       (call_args, cmm_target)
        = case target of
           StaticTarget lbl -> (args, CmmLit (CmmLabel 
-                                       (mkForeignLabel lbl Nothing False)))
-                               -- ToDo: what about the size here?
-                               -- it is currently tacked on by the NCG.
+                                       (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
+       -- will generate the suffix when the label is printed.
+      call_size
+       | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
+       | otherwise            = Nothing
+
+       -- 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"
@@ -195,15 +211,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