X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsForeign.lhs;h=751c5042ee2135b85a5c477bbf8af7445e274f8c;hb=9f592bb0ae0dc76bd3ec7729474057d2069bb4db;hp=1b269fab1f5cc0b21cc6dfd2cae55a848d56b642;hpb=c245355e6f2c7b7c95e9af910c4d420e13af9413;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 1b269fa..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}
 
 
@@ -209,7 +230,7 @@ dsFCall fn_id fcall = do
         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
         the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
-        work_id       = mkSysLocal FSLIT("$wccall") work_uniq worker_ty
+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 
         -- Build the wrapper
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
@@ -344,7 +365,7 @@ dsFExportDynamic id cconv = do
                         ]
           -- name of external entry point providing these services.
           -- (probably in the RTS.) 
-        adjustor   = FSLIT("createAdjustor")
+        adjustor   = fsLit "createAdjustor"
         
           -- Determine the number of bytes of arguments to the stub function,
           -- so that we can attach the '@N' suffix to its label if it is a
@@ -425,7 +446,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
   arg_cname n stg_ty
         | libffi    = char '*' <> parens (stg_ty <> char '*') <> 
-                      ptext SLIT("args") <> brackets (int (n-1))
+                      ptext (sLit "args") <> brackets (int (n-1))
         | otherwise = text ('a':show n)
 
   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
@@ -460,7 +481,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 		CCallConv   -> empty
 		StdCallConv -> text (ccallConvAttribute cc)
 
-  header_bits = ptext SLIT("extern") <+> fun_proto <> semi
+  header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 
   fun_args
     | null aug_arg_info = text "void"
@@ -469,8 +490,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
   fun_proto
     | libffi
-      = ptext SLIT("void") <+> ftext c_nm <> 
-          parens (ptext SLIT("void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
+      = ptext (sLit "void") <+> ftext c_nm <> 
+          parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
     | otherwise
       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
 
@@ -513,33 +534,33 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
     fun_proto  $$
     vcat 
      [ lbrace
-     ,   ptext SLIT("Capability *cap;")
+     ,   ptext (sLit "Capability *cap;")
      ,   declareResult
      ,   declareCResult
      ,   text "cap = rts_lock();"
 	  -- create the application + perform it.
-     ,   ptext SLIT("cap=rts_evalIO") <> parens (
+     ,   ptext (sLit "cap=rts_evalIO") <> parens (
 		cap <>
-		ptext SLIT("rts_apply") <> parens (
+		ptext (sLit "rts_apply") <> parens (
 		    cap <>
 		    text "(HaskellObj)"
 	         <> ptext (if is_IO_res_ty 
-				then SLIT("runIO_closure")
-				else SLIT("runNonIO_closure"))
+				then (sLit "runIO_closure")
+				else (sLit "runNonIO_closure"))
 		 <> comma
         	 <> expr_to_run
 		) <+> comma
 	       <> text "&ret"
 	     ) <> semi
-     ,   ptext SLIT("rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
+     ,   ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 						<> comma <> text "cap") <> semi
      ,   assignCResult
-     ,   ptext SLIT("rts_unlock(cap);")
+     ,   ptext (sLit "rts_unlock(cap);")
      ,   if res_hty_is_unit then empty
             else if libffi 
                   then char '*' <> parens (cResType <> char '*') <> 
-                       ptext SLIT("resp = cret;")
-                  else ptext SLIT("return cret;")
+                       ptext (sLit "resp = cret;")
+                  else ptext (sLit "return cret;")
      , rbrace
      ]