Commit cad81487 authored by simonmar's avatar simonmar
Browse files

[project @ 2005-01-10 13:53:14 by simonmar]

Obscure bugfix affecting foreign import "wrapper" with non-word-sized
argument types (eg. Double) on Windows.  The list of arguments types
returned by dsFExport was the boxed types, rather than the unboxed
types, so dsFExportDynamic couldn't get the correct sizes of the
argument types to the stub function.

It's more correct now, but not totally correct (see the comment for
details).

Noticed by: Wolfgang Thaller.
parent 038f8bb5
......@@ -18,6 +18,11 @@ import DsMonad
import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
ForeignImport(..), CImportSpec(..) )
import DataCon ( splitProductType_maybe )
#ifdef DEBUG
import DataCon ( dataConSourceArity )
import Type ( isUnLiftedType )
#endif
import MachOp ( machRepByteWidth )
import SMRep ( argMachRep, primRepToCgRep )
import CoreUtils ( exprType, mkInlineMe )
......@@ -287,7 +292,7 @@ dsFExport :: Id -- Either the exported Id,
-- the first argument's stable pointer
-> DsM ( SDoc -- contents of Module_stub.h
, SDoc -- contents of Module_stub.c
, [Type] -- arguments expected by stub function.
, [Type] -- primitive arguments expected by stub function.
)
dsFExport fn_id ty ext_name cconv isDyn
......@@ -389,10 +394,21 @@ dsFExportDynamic id cconv
-- (probably in the RTS.)
adjustor = FSLIT("createAdjustor")
sz_args = sum (map (machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep) stub_args)
-- 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
-- stdcall on Windows.
mb_sz_args = case cconv of
StdCallConv -> Just sz_args
StdCallConv -> Just (sum (map ty_size stub_args))
_ -> Nothing
-- NB. the calculation here isn't strictly speaking correct.
-- We have a primitive Haskell type (eg. Int#, Double#), and
-- we want to know the size, when passed on the C stack, of
-- the associated C type (eg. HsInt, HsDouble). We don't have
-- this information to hand, but we know what GHC's conventions
-- are for passing around the primitive Haskell types, so we
-- use that instead. I hope the two coincide --SDM
ty_size = machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep
in
dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
......@@ -437,9 +453,12 @@ mkFExportCBits :: FastString
-> Type
-> Bool -- True <=> returns an IO type
-> CCallConv
-> (SDoc, SDoc, [Type])
-> (SDoc,
SDoc,
[Type] -- the *primitive* argument types
)
mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
= (header_bits, c_bits, all_arg_tys)
= (header_bits, c_bits, all_prim_arg_tys)
where
-- Create up types and names for the real args
arg_cnames, arg_ctys :: [SDoc]
......@@ -461,8 +480,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
all_cnames_and_ctys
= map fst extra_cnames_and_tys ++ zip arg_cnames arg_ctys
all_arg_tys
= map snd extra_cnames_and_tys ++ arg_htys
all_prim_arg_tys
= map snd extra_cnames_and_tys ++ map getPrimTyOf arg_htys
-- stuff to do with the return type of the C function
res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
......@@ -561,4 +580,18 @@ showFFIType t = getOccString (getName tc)
tc = case tcSplitTyConApp_maybe (repType t) of
Just (tc,_) -> tc
Nothing -> pprPanic "showFFIType" (ppr t)
-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#). It assumes
-- that all the types we are interested in have a single constructor
-- with a single primitive-typed argument, which is true for all of the legal
-- foreign export argument types (see TcType.legalFEArgTyCon).
getPrimTyOf :: Type -> Type
getPrimTyOf ty =
case splitProductType_maybe (repType ty) of
Just (_, _, data_con, [prim_ty]) ->
ASSERT(dataConSourceArity data_con == 1)
ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
prim_ty
_other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment