put the @N suffix on stdcall foreign calls in .cmm code

This applies to EnterCriticalSection and LeaveCriticalSection in the RTS

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 6d8018a..28c43e1 100644 (file)
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -89,6 +89,7 @@ module CLabel (
        mkRtsApFastLabel,
 
        mkForeignLabel,
+        addLabelSize,
 
        mkCCLabel, mkCCSLabel,
 
@@ -364,6 +365,12 @@ mkApEntryLabel upd off             = RtsLabel (RtsApEntry   upd off)
 mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
 mkForeignLabel str mb_sz  is_dynamic = ForeignLabel str mb_sz is_dynamic
 
+addLabelSize :: CLabel -> Int -> CLabel
+addLabelSize (ForeignLabel str _ is_dynamic) sz
+  = ForeignLabel str (Just sz) is_dynamic
+addLabelSize label _
+  = label
+
        -- Cost centres etc.
 
 mkCCLabel      cc              = CC_Label cc

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 4cdb6eb..5a379c8 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -823,8 +823,8 @@ newLocal kind ty name = do
 -- classifies these labels as dynamic, hence the code generator emits the
 -- PIC code for them.
 newImport :: FastString -> ExtFCode ()
-newImport name =
-       addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
+newImport name
+   = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
 
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
@@ -909,15 +909,29 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
           case convention of
             -- Temporary hack so at least some functions are CmmSafe
             CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
-            _ -> case safety of
+            _ -> 
+             let expr' = adjCallTarget convention expr args in
+             case safety of
              CmmUnsafe ->
                 code (emitForeignCall' PlayRisky results 
-                   (CmmCallee expr convention) args vols NoC_SRT ret)
+                   (CmmCallee expr' convention) args vols NoC_SRT ret)
               CmmSafe srt ->
                 code (emitForeignCall' (PlaySafe unused) results 
-                   (CmmCallee expr convention) args vols NoC_SRT ret) where
+                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
                unused = panic "not used by emitForeignCall'"
 
+adjCallTarget :: CCallConv -> CmmExpr -> [(CmmExpr,MachHint)] -> CmmExpr
+#ifdef mingw32_TARGET_OS
+-- On Windows, we have to add the '@N' suffix to the label when making
+-- a call with the stdcall calling convention.
+adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
+  where size (e,_) = max wORD_SIZE (machRepByteWidth (cmmExprRep e))
+                 -- c.f. CgForeignCall.emitForeignCall
+#endif
+adjCallTarget _ expr _
+  = expr
+
 primCall
        :: [ExtFCode (CmmFormal,MachHint)]
        -> FastString

diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm
index 753e671..11af7c7 100644 (file)
--- a/rts/HeapStackCheck.cmm
+++ b/rts/HeapStackCheck.cmm
@@ -13,6 +13,8 @@
 #include "Cmm.h"
 
 #ifdef __PIC__
+import EnterCriticalSection
+import LeaveCriticalSection
 import pthread_mutex_unlock;
 #endif
 

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index d465709..805e1a4 100644 (file)
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -47,6 +47,8 @@ import __gmpz_com;
 import base_GHCziIOBase_NestedAtomically_closure;
 import pthread_mutex_lock;
 import pthread_mutex_unlock;
+import EnterCriticalSection
+import LeaveCriticalSection
 #endif
 
 /*-----------------------------------------------------------------------------

diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 43efa78..afd302a 100644 (file)
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -14,6 +14,8 @@
 
 #ifdef __PIC__
 import pthread_mutex_lock;
+import EnterCriticalSection
+import LeaveCriticalSection
 import base_GHCziBase_Czh_static_info;
 import base_GHCziBase_Izh_static_info;
 #endif