From: Simon Marlow <simonmar@microsoft.com>
Date: Wed, 14 May 2008 08:24:22 +0000 (+0000)
Subject: FIX #2276: foreign import stdcall "&foo" doesn't work
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=bca74f3e6bde807d688e39e6de28112ebcb4fa49

FIX #2276: foreign import stdcall "&foo" doesn't work
This turned out not to be too hard, just a matter of figuring out the
correct argument list size by peeking inside FunPtr's type argument,
and in the C backend we have to emit an appropriate prototype for the label.
---

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index cb07d06..d18f133 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -90,6 +90,7 @@ module CLabel (
 
 	mkForeignLabel,
         addLabelSize,
+        foreignLabelStdcallInfo,
 
 	mkCCLabel, mkCCSLabel,
 
@@ -372,6 +373,10 @@ addLabelSize (ForeignLabel str _ is_dynamic) sz
 addLabelSize label _
   = label
 
+foreignLabelStdcallInfo :: CLabel -> Maybe Int
+foreignLabelStdcallInfo (ForeignLabel _ info _) = info
+foreignLabelStdcallInfo _lbl = Nothing
+
 	-- Cost centres etc.
 
 mkCCLabel	cc		= CC_Label cc
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 0718930..a0661cd 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -828,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
@@ -839,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) }
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index d10e5db..751c504 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -33,6 +33,7 @@ import Literal
 import Module
 import Name
 import Type
+import TyCon
 import Coercion
 import TcType
 
@@ -143,15 +144,35 @@ dsCImport :: Id
 	  -> CCallConv
 	  -> Safety
 	  -> DsM ([Binding], SDoc, SDoc)
-dsCImport id (CLabel cid) _ _ = do
-   (resTy, foRhs) <- resultWrapper (idType id)
+dsCImport id (CLabel cid) cconv _ = do
+   let ty = idType id
+   (resTy, foRhs) <- resultWrapper ty
    ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
-    let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
+    let
+        rhs = foRhs (mkLit (MachLabel cid stdcall_info))
+        stdcall_info = fun_type_arg_stdcall_info cconv ty
+    in
     return ([(id, rhs)], empty, empty)
+
 dsCImport id (CFunction target) cconv safety
   = dsFCall id (CCall (CCallSpec target cconv safety))
 dsCImport id CWrapper cconv _
   = dsFExportDynamic id cconv
+
+-- For stdcall labels, if the type was a FunPtr or newtype thereof,
+-- then we need to calculate the size of the arguments in order to add
+-- the @n suffix to the label.
+fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info StdCallConv ty
+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
+    tyConUnique tc == funPtrTyConKey
+  = let
+       (_tvs,sans_foralls)            = tcSplitForAllTys arg_ty
+       (fe_arg_tys, orig_res_ty)      = tcSplitFunTys sans_foralls
+    in 
+        Just $ sum (map (machRepByteWidth . typeMachRep . getPrimTyOf) fe_arg_tys)
+fun_type_arg_stdcall_info _other_conv _
+  = Nothing
 \end{code}