FIX #2276: foreign import stdcall "&foo" doesn't work

[ghc-hetmet.git] / compiler / cmm / PprC.hs

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 9a3a3a2..a0661cd 100644 (file)
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -203,25 +203,44 @@ pprStmt stmt = case stmt of
        where
          rep = cmmExprRep src
 
-    CmmCall (CmmCallee fn cconv) results args safety _ret ->
+    CmmCall (CmmCallee fn cconv) results args safety ret ->
         maybe_proto $$
        pprCall ppr_fn cconv results args safety
        where
-        ppr_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
+        cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
+
+        real_fun_proto lbl = char ';' <> 
+                        pprCFunType (pprCLabel lbl) cconv results args <> 
+                        noreturn_attr <> semi
+
+        data_proto lbl = ptext (sLit ";EI_(") <> 
+                         pprCLabel lbl <> char ')' <> semi
+
+        noreturn_attr = case ret of
+                          CmmNeverReturns -> text "__attribute__ ((noreturn))"
+                          CmmMayReturn    -> empty
 
         -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
-       maybe_proto = 
+       (maybe_proto, ppr_fn) = 
             case fn of
-             CmmLit (CmmLabel lbl) | not (isMathFun lbl) -> 
-                  ptext (sLit ";EI_(") <+> pprCLabel lbl <> char ')' <> semi
-                        -- we declare all called functions as data labels,
-                        -- and then cast them to the right type when calling.
-                        -- This is because the label might already have a 
-                        -- declaration as a data label in the same file,
-                        -- e.g. Foreign.Marshal.Alloc declares 'free' as
-                        -- both a data label and a function label.
+             CmmLit (CmmLabel lbl) 
+                | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl)
+                        -- stdcall functions must be declared with
+                        -- a function type, otherwise the C compiler
+                        -- doesn't add the @n suffix to the label.  We
+                        -- can't add the @n suffix ourselves, because
+                        -- it isn't valid C.
+                | CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl)
+                | not (isMathFun lbl) -> (data_proto lbl, cast_fn)
+                        -- we declare all other called functions as
+                        -- data labels, and then cast them to the
+                        -- right type when calling.  This is because
+                        -- the label might already have a declaration
+                        -- as a data label in the same file,
+                        -- e.g. Foreign.Marshal.Alloc declares 'free'
+                        -- as both a data label and a function label.
              _ -> 
-                   empty {- no proto -}
+                   (empty {- no proto -}, cast_fn)
                        -- for a dynamic call, no declaration is necessary.
 
     CmmCall (CmmPrim op) results args safety _ret ->
@@ -809,7 +828,8 @@ pprExternDecl :: Bool -> CLabel -> SDoc
 pprExternDecl in_srt lbl
   -- do not print anything for "known external" things
   | not (needsCDecl lbl) = empty
-  | otherwise              = 
+  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
+  | otherwise =
        hcat [ visibility, label_type (labelType lbl), 
               lparen, pprCLabel lbl, text ");" ]
  where
@@ -820,6 +840,13 @@ pprExternDecl in_srt lbl
      | externallyVisibleCLabel lbl = char 'E'
      | otherwise                  = char 'I'
 
+  -- If the label we want to refer to is a stdcall function (on Windows) then
+  -- we must generate an appropriate prototype for it, so that the C compiler will
+  -- add the @n suffix to the label (#2276)
+  stdcall_decl sz =
+        ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
+        <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRepCType wordRep)))
+        <> semi
 
 type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
 newtype TE a = TE { unTE :: TEState -> (a, TEState) }