hdirect-0.21.0: src/MarshallMethod.lhs
%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Nov. 24th 2003 10:04 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
The marshalling of an IDL method
\begin{code}
module MarshallMethod
( cgMethod
, cgProperty
, findParamDependents
, removeDependers
, removeDependees
, removeDependents
, allocateOutParams
, marshallParams
, freeInParamStorage
, primDecl
, mkResult
) where
import BasicTypes
import Literal ( iLit, Literal(..), IntegerLit(..) )
import AbstractH ( HDecl )
import qualified AbstractH as Haskell ( Expr, Type )
import NativeInfo ( lONG_SIZE )
import AbsHUtils
import Attribute
import Env ( lookupEnv, replaceElt )
import Opts ( optKeepHRESULT, optUseDispIDs,
optCoalesceIsomorphicMethods, optPrefixIfaceName,
optSubtypedInterfacePointers,
optHaskellToC, optIgnoreHiddenMeths, optIgnoreRestrictedMeths,
optGenDefs, optExplicitIPointer, optHugs, optDualVtbl,
optLongLongIsInteger, optCorba, optNoShareFIDs, optCom
)
import CoreIDL
import CoreUtils ( DependInfo, DepVal(..),
findParamTy, findParam, isSimpleTy, addrTy,
mkHaskellVarName, mkHaskellTyConName, mkIfaceTypeName,
removePtrAndArray, computeArrayConstraints, removePtrAll,
isVoidTy, isPtrPointerTy, resultParam,
lookupDepender, mkParam, toCType, keepValueAsPointer,
isHRESULT, removePtr, sizeAndAlignModulus,
binParams, tyFun, word32Ty, iUnknownTy,
iPointerParam, isIntegerTy, isIfaceTy
)
import CgMonad
import MarshallMonad
import MarshallType ( marshallType
, unmarshallType
, refUnmarshallType
, allocPointerTo
, coreToHaskellExpr
, mbFreeType
, szType
, coerceTy
, coerceToInt
)
import MarshallCore ( toHaskellTy
, paramToHaskellType
, toHaskellBaseTy
, toHaskellBaseMethodTy
, autoTypeToHaskellTy
, constrainIIDParams
)
import MarshallDep
import MarshallUtils
import MarshallAuto
import LibUtils ( comLib
, iDispatch
, iUnknown
, ioExts
, outPrefix
, autoLib
, allocBytes
, fromIntegralName
, fromMaybeName
, mapName
, mkPrimitiveName
, mkPrimExportName
, invokeAndCheck
, primInvokeIt
, invokeAndCheck
, invokeIt
, marshallPrefix
, withForeignPtrName
, check2HR
, checkHR
)
import Maybe ( fromMaybe, isJust, fromJust )
import Monad ( when, mplus )
import Utils ( concMaybe )
\end{code}
\begin{code}
cgMethod :: Id
-> CallConv
-> Result
-> [Param]
-> Maybe Int
-> Maybe Name -- name which implements the external call.
-> CgM HDecl
cgMethod i cconv result params offs mb_prim =
-- fetch some state out of the monad and go..
getDeclName $ \ mname -> do
dname <- getDllName
iface <- getIfaceName
objFlag <- getInterfaceFlag
forClient <- getClientFlag
isIEnum <- getIEnumFlag
methNo <- getMethodNumber offs
inh <- getIfaceInherit
hasIso <-
(if (not optCoalesceIsomorphicMethods)
then return Nothing
else isIsomorphicMethod (idOrigName i) result params)
let
isObj = objFlag /= StdFFI
isAuto =
case objFlag of
ComIDispatch isDual ->
not isDual || (not optDualVtbl && permissibleAutoSig result params)
_ -> False
isServer =
not forClient &&
not (attrs `hasAttributeWithName` "source")
case hasIso of
Just False -- already generated code for isomorphic method, so
-- don't generate code for this one.
| optCoalesceIsomorphicMethods -> return emptyDecl
_
| isHidden -> return emptyDecl -- ToDo: support this for binary interfaces??
| otherwise -> do
{- methods that are marked with call_as() are only
used when generating proxy/stub code for remoting.
We use them when in 'COM mode' too, since these methods
have at times attributes that are more helpful to us.
[No, afraid not - the signature of the remoting
method does not have to be isomorphic to the local
method. See comment in the desugaring code.]
In non-COM mode, call_as() is used as a means to
avoid having to have a 1-1 mapping between Haskell
function stub names and the name of the external
entry point to invoke.
-}
let
meth_i = i
meth_nm = ieValue (mkHaskellVarName (idName meth_i))
export_decl = addExport meth_nm
enum_meth_ok = isIEnum && not isServer && isIEnumOK
export_decl
(flg, prim_decl, mb_prim2) <- primDecl isObj isServer (not enum_meth_ok && not isAuto)
i dname mname cconv r_ty params
let decl' = mkMethod iface mname inh hasIso objFlag enum_meth_ok isServer
mb_prim mb_prim2
cconv methNo meth_i result params
decl = helpString `andDecl` decl'
case (isAuto || enum_meth_ok || isJust mb_prim) of
True -> return decl -- the primitives are elsewhere!
False -> do
needStubs flg
hasPrims
return ( decl `andDecl` prim_decl )
where
r_ty = resultType result
attrs = idAttributes i
isHidden =
attrs `hasAttributeWithName` "ignore" ||
(( optIgnoreHiddenMeths || optIgnoreRestrictedMeths ) &&
attrs `hasAttributeWithNames` ["hidden", "restricted"])
helpString = helpStringComment i
{-
Some typelibs are in such a pitiful state, so we have to make
sure that the enum method is in a good enough shape.
-}
isIEnumOK =
case idName i of
_:'e':'x':'t':_ -> right_shape
_:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> right_shape
_ -> True
where
right_shape = [In,Out,Out] == map (paramMode) params
\end{code}
The function that does the real work of generating a stub. It is
currently a mess, and is scheduled for a cleanup/rewrite Real Soon.
\begin{code}
mkMethod :: Name -- interface the method belongs to
-> String -- it's module
-> [QualName] -- interface inheritance (name) chain
-> Maybe Bool
-> IfaceType
-> Bool
-> Bool
-> Maybe Name
-> Maybe Name
-> CallConv
-> Int -- method number (in vtbl)
-> Id -- method Id / name.
-> Result
-> [Param]
-> HDecl
mkMethod iface mname inh hasIso objFlag isIEnum isServer
mb_prim mb_prim_nm cconv methNo methId result params
| isAuto = auto_tysig `andDecl` auto_def
| isIEnum = enum_tysig `andDecl` enum_def
| otherwise = m_tysig `andDecl` m_def
where
r_ty = resultType result
isObj = objFlag /= StdFFI
(isAuto, isDual) =
case objFlag of
ComIDispatch isD -> (not isD || (not optDualVtbl && permissibleAutoSig result params), isD)
_ -> (False, False)
m_name = mkHaskellVarName name
name = idName methId
m_tysig = mkTypeSig m_name in_tys result_ty
m_def = funDef m_name in_pats m_rhs
auto_tysig = mkTypeSig m_name
in_tys
(funTy i_pointer_ty (returnType (tuple res_ty)))
enum_def = funDef m_name in_pats enum_rhs
enum_tysig = mkTypeSig m_name enum_type_args enum_type_res
enum_elt_ty = toHaskellTy True (removePtrAndArray (paramType (head results)))
(enum_type_args, enum_type_res) =
let
(res_type:is) = (result_ty:in_tys)
--OLD: (r_ty:is) = relabelTypes (result_ty:in_tys)
in
{- Bad boy, go sit in the corner. -}
case name of
_:'e':'x':'t':_ -> (is, funTy i_pointer_ty (io (tyList enum_elt_ty)))
_:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ ->
(is, funTy i_pointer_ty (io (tyList enum_elt_ty)))
_ -> (is, res_type)
enum_rhs = funApp enum_fun args
where
enum_fun = mkQVarName comLib ("enum" ++ enumName)
{-
When MIDL generates a typelib for the following
[object,...]
interface IA : IUnknown {
[local]
HRESULT f ();
[call_as(f)]
HRESULT remoteF();
};
The type library gets a method named "remoteF". I'm not
sure that this is right, but what can you do?
-}
enumName =
case idOrigName methId of
_:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> "Next"
n -> n
-- peel off two levels of indirection (one for the [out] pointer)
elt_ty = removePtr (paramType (head results))
sz_of = szType elt_ty
write_elt = refUnmarshallType stubMarshallInfo elt_ty
args =
-- too beautiful, man..
case name of
_:'e':'x':'t':_ -> sz_of : write_elt : the_args
_:'e':'m':'o':'t':'e':'N':'e':'x':'t':_ -> sz_of : write_elt : the_args
_ -> the_args
the_args =
case (map (mkHVar.paramId) meth_params) of
[] -> []
[x] -> [x]
-- the library impl of Skip() and Next() expects a Word32 as first
-- arg, so make sure that's the case here.
(x:xs) -> coerceTy (paramType (head meth_params)) word32Ty x : xs
auto_def = funDef m_name in_pats auto_rhs
auto_rhs = funApp call_wrapper the_args
where
fun_id
| with_dispids = integerLit dispid
| otherwise = stringLit (idOrigName methId)
with_dispids = optUseDispIDs && has_dispid
call_wrapper = classifyCall methId with_dispids params result
the_args
| optExplicitIPointer = args ++ [var "iptr"]
| otherwise = args
args = fun_id :
(hList (map marshallVariantParam ins)):
map unmarshallVariantParam (results)
has_dispid = isJust mb_dispid
mb_dispid = getDispIdAttribute (idAttributes methId)
(Just dispid) = mb_dispid
(pars, ins,outs,inouts,res) = binParams params
param_names = map (idName.paramId) params
returnType t
| isPure = t
| otherwise = io t
isPure = (idAttributes methId) `hasAttributeWithName` "pure"
meth_params =
case mb_prim of
Nothing -> meth_params'
Just _ -> prim_param:meth_params'
-- extend the param list if the 'result' parameter, so that
-- we can use the result in dependent argument expression (
-- e.g., [out,length_is(result)]int* f, ...
params_and_result
= params ++ [resultParam (resultType result)]
(prim_params, meth_params', result_ty)
| isAuto
= ( []
, real_params ++ (if optExplicitIPointer then [iptr_param] else [])
, funTy i_pointer_ty (returnType (tuple res_ty))
)
| isObj || isIEnum
= ( mptr_param:iptr_param:params
, real_params ++ [iptr_param]
, funTy i_pointer_ty (returnType (tuple res_ty))
)
| otherwise =
( params
, real_params
, returnType (tuple res_ty)
)
i_pointer_ty
| optSubtypedInterfacePointers && not isIsoMethod
= tyCon (mkHaskellTyConName (mkIfaceTypeName iface)) [tyVar "a"]
| (isAuto || isDual) && isIsoMethod && optSubtypedInterfacePointers
= mkTyCon iDispatch [tyVar "a"]
| isIsoMethod && optSubtypedInterfacePointers
= mkTyCon iUnknown [tyVar "a"]
| isAuto && isIsoMethod
= mkTyConst iDispatch
| optSubtypedInterfacePointers
= tyCon (mkHaskellTyConName (mkIfaceTypeName iface)) [tyVar "a"]
| otherwise
= tyConst (mkHaskellTyConName iface)
isIsoMethod = fromMaybe False hasIso
-- building the Haskell type of the method/function.
(in_tys_1, res_ty) =
constrainIIDParams
(paramToHaskellType par_deps isServer isAuto False)
(paramToHaskellType res_deps isServer isAuto True)
real_params
results
{-
res_ty = map (paramToHaskellType res_deps isServer isAuto True) results
-}
in_tys =
-- if the primitive method is passed in as arg, prefix it
-- to the parameter list.
(if isJust mb_prim then
((toHaskellBaseMethodTy False prim_params result):)
else
id) in_tys_1
-- map (paramToHaskellType par_deps isServer isAuto False) real_params
in_p_tys = map (\ p -> ( idName (paramId p)
, toParamPrimTy isServer p
)
) prim_params
iptr_param = iPointerParam iface
mptr_param = mkParam "methPtr" In
(Pointer Ptr True Void)
prim_param = mkParam (fromJust mb_prim) In
(tyFun cconv result prim_params)
in_pats = map (varPat.mkHVar.paramId) meth_params
meth_result = mkResult results
unsafeWrap e
| isPure = funApp (mkQVarName ioExts "unsafePerformIO") [e]
| otherwise = e
m_rhs =
unsafeWrap $
runMm (Just (mkHaskellVarName (idName methId))) param_names meth_result $ do
marshallDependents False{-not inside struct-} False{-not for server proxies-}
par_deps (findParamTy params_and_result) -- in and in-out params
allocateOutParams (raw_inout_deps++raw_out_deps)
(findParam params_and_result)
(removeDependees raw_inout_deps outs)
marshallParams True{-marshall-} False isServer (removeDependents in_deps real_ins)
marshallParams True{-marshall-} False isServer (removeDependers raw_inout_deps raw_inouts)
setupMethodCall isObj methNo iface inh result in_p_tys
(thePrimCall isObj mname mb_prim mb_prim_nm methId result prim_params)
freeInParamStorage in_deps ins
okResult isObj methId result
unmarshallOutParams isServer (removeDependers (out_deps ++ inout_deps) real_outs)
when (not ignoreResult)
(unmarshallResult isServer methId{idName=outPrefix++idName methId} r_ty)
marshallParams False False isServer (removeDependers (inout_deps++out_deps) real_inouts)
unmarshallDependents False True out_deps (findParamTy params_and_result)
unmarshallDependents False False inout_deps (findParamTy params_and_result)
(results, ignoreResult) =
let results'
| isAuto = (outs ++ inouts)
| otherwise = real_res
in
case r_ty of
Void -> (results', True)
_
| (isHRESULT result && not optKeepHRESULT) ||
((idAttributes methId) `hasAttributeWithName` "hs_ignore_result")
-> (results', True)
| otherwise -> (results' ++ [res_param], isSimpleTy r_ty && not (isIfaceTy r_ty))
res_param =
let p = mkParam (outPrefix ++ name) Out r_ty in
p{ paramOrigType=resultOrigType result
, paramId=(paramId p){idAttributes=idAttributes methId}
} -- replace attributes.
(real_params, par_deps) = findParamDependents True pars
(_, in_deps) = findParamDependents True ins
(real_ins, _) = findParamDependents False ins
-- For the [out] params, there's a wondrous special case:
-- [out,size_is(x),length_is(*px)]void* pv
--
-- Here we don't want to unmarshall pv into a list (it's
-- really a chunk of mem), but want to consider pv to
-- be a dependent argument for the purposes of allocating
-- a chunk of memory to pass in. So, use a pair of DependInfos,
-- one to use for marshalling ('out_deps') and another
-- to use when allocating out-param storage ('raw_out_deps.')
(real_outs', out_deps) = findParamDependents True outs
(_, raw_out_deps) = findParamDependents False outs
real_outs = filter (not.(`hasAttributeWithName` "ptr").idAttributes.paramId) real_outs'
(real_inouts, inout_deps) = findParamDependents False inouts
(raw_inouts, raw_inout_deps) = findParamDependents True inouts
(real_res, res_deps) = findParamDependents True res
\end{code}
Generating code for dispinterface properties is real straightforward,
\begin{code}
cgProperty :: Id -> Type -> Id -> Id -> CgM HDecl
cgProperty i ty seti geti = do
if_name <- getIfaceName
let
prop_iface_ty
| optSubtypedInterfacePointers = tyCon if_name [tyVar "a"]
| otherwise = tyConst if_name
get_prop_tysig = mkTypeSig get_prop_name
[prop_iface_ty]
(io (prop_ty Out))
set_prop_tysig = mkTypeSig set_prop_name
[prop_ty In, prop_iface_ty]
(io tyUnit)
prop_ty kind = autoTypeToHaskellTy kind ty
get_prop_decl = funDef get_prop_name [] get_prop_rhs
set_prop_decl = funDef set_prop_name [varPat (var "prop")] set_prop_rhs
get_prop_name = if_prefix ++ idName geti
set_prop_name = if_prefix ++ idName seti
if_prefix
| optPrefixIfaceName = mkHaskellVarName (mkIfaceTypeName if_name) ++ "_"
| otherwise = ""
get_prop_rhs = funApp getProp [ prop_id, hList []
, marshallVariant "out" ty
]
set_prop_rhs = funApp setProp [ prop_id
, hList [funApply (marshallVariant "in" ty) [var "prop"]]
]
prop_id
| optUseDispIDs && has_dispid = integerLit d_id
| otherwise = stringLit (idName i)
setProp = mkQVarName autoLib ("propertySet" ++ dispid)
getProp = mkQVarName autoLib ("propertyGet" ++ dispid)
has_dispid = isJust mb_dispid
mb_dispid = getDispIdAttribute (idAttributes i)
(Just d_id) = mb_dispid
dispid
| optUseDispIDs = "ID"
| otherwise = ""
return ( get_prop_tysig `andDecl`
get_prop_decl `andDecl`
set_prop_tysig `andDecl`
set_prop_decl
)
\end{code}
\begin{code}
marshallParams :: Bool -> Bool -> Bool -> [Param] -> Mm ()
marshallParams marsh don'tFree isServer ps = do
sequence (map marshallParam ps)
return ()
where
marshallParam p
| isVoidTy ty
|| isSimpleTy ty
|| keepValueAsPointer ty -- keep pointers to complex types
-- external.
= return ()
| otherwise =
let nm = idName (paramId p)
nm' = "in__" ++ nm
pats
| isIntegerTy ty = tuplePat [patVar (nm ++ "_hi"), patVar (nm ++ "_lo")]
| otherwise = patVar nm
pats'
| isIntegerTy ty = tuplePat [patVar (nm' ++ "_hi"), patVar (nm' ++ "_lo")]
| otherwise = patVar nm'
in
-- The hack to prefix the value with res__ in the proxy/server case
-- requires that the same thing is done in MarshallServ.marshallMethod.meth_result
--
-- Ditto for in__ prefixing the result of unmarshaling proxy args;
-- MarshallServ.marshallMethod needs to be in on this (less-than-tasteful) game.
if isServer
then if marsh
then let res__nm = var ("res__" ++ nm) in
if (paramMode p == InOut)
then addCode (bind_ (funApply (marshaller p ty) [ var nm, res__nm ]))
else addCode (bind (funApply (marshaller p ty) [res__nm]) res__nm)
else if (paramMode p == InOut)
then addCode (genBind (funApply (marshaller p ty) [var nm]) pats')
else addCode (genBind (funApply (marshaller p ty) [var nm]) pats)
else addCode (genBind (funApply (marshaller p ty) [var nm]) pats)
where
ty = paramType p
marshaller p
| marsh = marshallType stubMarshallInfo{forInOut=(paramMode p == InOut), forProxy=isServer}
| otherwise = unmarshallType stubMarshallInfo{ forInOut=(paramMode p == InOut)
, doFree=not (don'tFree || don'tFree_t)
, forProxy=isServer
}
where
don'tFree_t = (idAttributes (paramId p)) `hasAttributeWithName` "nofree"
unmarshallOutParams :: Bool -> [Param] -> Mm ()
unmarshallOutParams isServer ls = do
sequence (map (unmarshallOutParam isServer) ls)
return ()
unmarshallOutParam :: Bool -> Param -> Mm ()
unmarshallOutParam isServer p
| isVoidTy ty ||
keepValueAsPointer ty ||
isPtrPointerTy ty
{- doesn't make sense.
(optHaskellToC &&
isAbstractTy ty &&
not (isAbstractFinalTy ty))
-}
= return ()
| otherwise =
addCode (bind (funApply (unmarshallType stubMarshallInfo{ forInOut=(paramMode p == InOut)
, doFree=not don'tFree
, forProxy=isServer}
ty) [nm]) nm)
where
ty = paramType p
nm = var (idName (paramId p))
don'tFree = (idAttributes (paramId p)) `hasAttributeWithName` "nofree"
unmarshallResult :: Bool -> Id -> Type -> Mm ()
unmarshallResult _ _ Void = return ()
unmarshallResult isServer i ty =
addCode (bind (funApply (unmarshallType stubMarshallInfo{doFree= not don'tFree, forProxy=isServer} ty) [nm]) nm)
where
nm = var (idName i)
don'tFree = (idAttributes i) `hasAttributeWithName` "nofree"
allocateOutParams :: DependInfo -> (Name -> Param) -> [Param] -> Mm ()
allocateOutParams deps lookup_param params = do
sequence (map allocate params)
return ()
where
allocate p
| isVoidTy ty = return ()
| otherwise = addCode (bind allocOut (var nm))
where
i = paramId p
ty = paramType p
ty' = removePtrAll ty
nm = idName i
allocOut =
case (lookupDepender deps i) of
Nothing -> allocPointerTo ty
Just ls ->
let
(_,_,sz_allocs) = computeArrayConstraints False{-not unmarshaling-} ls
in
-- allocate space big enough to hold what function is going
-- to return back, i.e.,
-- [out]int* -> allocBytes s[Int32] (returning pointer to it.)
-- [out]int** -> allocBytes s[t*]
--
-- Note: if the [out] param is a constructed type, we don't need to
-- to allocate space for the objects pointed to by any embedded pointers
-- (that's the task of the callee.)
-- [ No need to plug the pointers with NULLs either, AFAIK. -- sof 5/98 ]
--
--
-- ToDo: assert that the ty is of a pointer or array nature.
case sz_allocs of
[] -> allocPointerTo ty
(DepNone:_) -> allocPointerTo ty
-- The next case is wrong, even if we've got
-- [size_is(*e)] pinned onto an [out] parameter,
-- we'll need to allocate enough space to hold
-- (*e) elements.
--(DepVal _ (Unary Deref _):_) -> allocPointerTo addrTy
(DepVal Nothing e:_) ->
case ty' of
Pointer _ _ Void -> funApp allocBytes [coerceToInt e]
_ ->
funApp allocBytes
[ binOp Mul
(funApp fromIntegralName [szType ty'])
(coerceToInt e)
]
(DepVal (Just v) e:_) ->
let
coerce = varName fromIntegralName
h_e = coreToHaskellExpr e
in
case paramType (lookup_param v) of
Pointer Unique _ _ ->
funApp allocBytes
[binOp Mul
(funApp fromIntegralName [szType ty'])
(funApp fromMaybeName
[ var "0"
, funApp mapName [coerce, h_e]
])]
_ ->
let e' = coerceToInt e in
case ty' of
Pointer _ _ Void -> funApp allocBytes [e']
_ -> funApp allocBytes
[ binOp Mul
(funApp fromIntegralName [szType ty'])
e'
]
-- parameter list has all (in)out parameters plus function result.
mkResult :: [Param] -> Haskell.Expr
mkResult ps =
case ps of
[p] | isVoidTy (paramType p) -> ret unit
| otherwise -> ret (mkVal p)
_ -> ret (tup (map mkVal ps))
where
mkVal p = var (idName (paramId p))
\end{code}
Create the FFI declaration for the foreign function/object method
we're interfacing to. If it's a (COM) method, we give it two
extra Addr arguments, one contains the address of the method, the
other the interface pointer.
If we end up wanting to perform an indirect callout
\begin{code}
primDecl :: Bool
-> Bool
-> Bool
-> Id
-> String
-> String
-> CallConv
-> Type
-> [Param]
-> CgM (Bool, HDecl, Maybe Name)
primDecl isObj isServer trySharing f dname mname cc res params
| isServer = do
let sig = mkTySig param_h_tys res_hs_ty
mb_res <- lookupDynStub sig
case mb_res of
Just (True,r) | not optNoShareFIDs ->
return (False, emptyDecl, Just r)
_ -> do
when (not optNoShareFIDs) (addDynStub server_nm sig True)
return (False, fexport cc Nothing server_nm server_ty, Nothing)
| not isObj =
return (needs_wrapper, prim cc loc_spec prim_nm prim_ty needs_wrapper c_ty_args c_res_ty, Nothing)
| otherwise = do
let sig = mkTySig param_h_tys res_hs_ty
mb_res <- lookupDynStub sig
case mb_res of
Just (False,r) | not optNoShareFIDs && trySharing && not has_structs -> do
return (False, emptyDecl, Just r)
_ -> do
when (trySharing && not has_structs) (addDynStub prim_nm sig False)
return ( has_structs
, primcst cc prim_nm prim_ty has_structs c_ty_args c_res_ty
, Nothing
)
where
nm = idName f
orig_nm = idOrigName f
attrs = idAttributes f
the_dname =
case (findAttribute "dllname" attrs) of
Just (Attribute _ [ParamLit (StringLit s)]) -> s
_ -> dname
loc_spec =
case concMaybe (findAttribute "call_as" attrs)
(findAttribute "entry" attrs) of
Nothing -> (the_dname, Nothing, orig_nm, Nothing)
Just (Attribute _ [ParamVar v]) -> (the_dname, Nothing, v, Nothing)
Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) ->
let
stub_nm = mkPrimitiveName (show x)
in
(the_dname, Just x, stub_nm, sz)
Just (Attribute _ [ParamLit (StringLit v)]) -> (the_dname, Nothing, v, Nothing)
_ -> (the_dname, Nothing, orig_nm, Nothing)
{-
Hugs' primitives live in an thoroughly flat namespace - if you have got
two primitive decls called "prim_foo", the first that's loaded, is used
throughout. Better not let that happen here, so we prepend the module
name.
[I've submitted a fix for this for Hugs98; hopefully it will be included..]
8/99 - add module prefix on the non-Hugs side too ; otherwise we run into trouble
when linking object files that contain identically named stubs.
-}
prim_nm = mkPrimitiveName (mname ++ '_':nm)
needs_wrapper =
has_structs ||
case loc_spec of
(_, Just _, _, _) -> True
_ -> False
has_structs = any (fst) ls
ls@(c_res_ty:c_ty_args) = map (isStruct.toCType) (res:param_tys')
where
isStruct (Left x) = (False, x)
isStruct (Right x) = (True, x)
sz
| not optGenDefs = Nothing
| otherwise =
case cc of
Stdcall ->
let stuff = map ((sizeAndAlignModulus Nothing).paramType) params
p_sz = foldl (al_param) 0 stuff
al_param siz (sz_t,_) =
let --sz' = align sz modu -- hmm
sz_t'
| sz_t < lONG_SIZE = lONG_SIZE -- everything that's less than word size
-- is rounded up to be exactly that.
| otherwise = sz_t
in (siz + sz_t')
in
Just p_sz
_ -> Nothing
server_nm = mkPrimExportName nm
server_ty =
case generaliseTys [prim_ty] of
([t], mb) -> mbCtxtTyApp mb (funTy t (io tyAddr))
prim_ty = funTys param_hs_tys (io res_hs_ty)
{-
We're using toHaskellBaseTy here to map to the *primitive*
Haskell representation of an IDL type.
-}
param_hs_tys
| isServer = tyPtr (uniqueTyVar "a") : param_h_tys
| isObj =
if optCom || attrs `hasAttributeWithName` "finaliser" then
tyAddr : tyAddr : param_h_tys
else
tyAddr : tyAddr : param_h_tys
| otherwise = param_h_tys
(param_h_tys, _) =
constrainIIDParams (toPtrTy .(toParamPrimTy isServer))
(toPtrTy .(toParamPrimTy isServer))
params
outs
-- param_h_tys = map (toPtrTy.toParamPrimTy isServer) params
(_, _, outs, _, _) = binParams params
param_tys'
| isServer = addrTy:p_tys
| isObj = addrTy:iUnknownTy:p_tys
| otherwise = p_tys
where
p_tys = map paramType params
res_hs_ty = toHaskellBaseTy True res
toParamPrimTy isServer p
| pattrs `hasAttributeWithName` "foreign" = tyForeignObj
| otherwise = toHaskellBaseTy (isResult || isServer) (paramType p)
where
pattrs = idAttributes (paramId p)
mode = paramMode p
isResult = mode == Out ||
-- mode == InOut ||
paramDependent p
\end{code}
If we're compiling a COM method, we need to swizzle the function
pointer out of the interface pointer in order to perform the
actual call. @setMethodCall@ does this, dereferencing the i-pointer
(assume it is in scope as @iptr@), binding the function pointer
to @methPtr@.
\begin{code}
setupMethodCall :: Bool
-> Int
-> String
-> [QualName]
-> Result
-> [(Name, Haskell.Type)]
-> (Haskell.Expr, Maybe Haskell.Expr)
-> Mm ()
setupMethodCall isObj methNo ifaceName inh result param_tys methCall
| not isObj = addCode ( binder mCall )
| isHRESULT result = addCode (
binder
(funApp
invokeAndCheck
[ lam [varPat methPtr, varPat iptr] mCall
, offset
, iptr
]))
| otherwise = addCode ( binder invokeMethod )
where
(mCall0, mbRes) = methCall
mCall = unravel mCall0
invokeMethod
| optHaskellToC || optCorba
= funApp primInvokeIt
[ lam [varPat methPtr, varPat iptr] mCall
, offset
, funApp m_iptr [iptr]
]
| otherwise = funApp invokeIt
[ lam [varPat methPtr, varPat iptr] mCall
, offset
, iptr
]
m_iptr =
case inh of
[] -> prefix marshallPrefix (mkQVarName Nothing ifaceName)
(x:_) -> prefix marshallPrefix x
-- unwrap the ForeignPtrs.
unravel cont
= foldr (\ (f,_) acc -> funApp withForeignPtrName [var f, lam [patVar f] acc])
cont
fs
where fs = filter (isFOTy.snd) param_tys
binder =
case mbRes of
Nothing -> bind_
Just v -> (\ m n -> bind m v n) -- fp; dontcha just love it!
iptr = var "iptr"
methPtr = var "methPtr"
offset = lit (iLit methNo)
\end{code}
Call the primitive. Assume that all arguments have been
marshalled into an appropriate form and that their marshalled
representations are in scope as the names given in the parameter list.
\begin{code}
thePrimCall :: Bool
-> String
-> Maybe Name
-> Maybe Name
-> Id
-> Result
-> [Param]
-> (Haskell.Expr, Maybe Haskell.Expr)
thePrimCall isComMeth mname mb_prim mb_prim_nm f res params
| isVoidTy r_ty || (isComMeth && isHRESULT res) = (f_app, Nothing)
| otherwise = (f_app, Just r_res)
where
f_app = funApp (mkVarName meth_name) args
r_ty = resultType res
r_res = var (outPrefix ++ idName f)
args = foldr mkArg [] params
mkArg p acc =
case paramType p of
Integer LongLong _ | optHugs && optLongLongIsInteger
-> var (nm ++ "_lo") : var (nm ++ "_hi") : acc
_ -> var nm : acc
where
nm = idName (paramId p)
-- see primDecl comment.
fun_nm = mname ++ '_':idName f
meth_name =
case mb_prim `mplus` mb_prim_nm of
Nothing -> mkPrimitiveName fun_nm
Just x -> x
{-
The predicate may look a bit odd - check the
HRESULT return code if it is *not* an object
method. The reason for this is that the HRESULT
return code have already been checked for by
special object method call wrappers.
If the result has the attribute [usesgetlasterror],
then in the event of error, we fish out the return
code and msg by calling GetLastError() - Win32 specific,
although we could give [usesgetlasterror] a valid
interpretation on most Unices too (use errno.)
-}
okResult :: Bool -> Id -> Result -> Mm ()
okResult isObj f res
| attrs `hasAttributeWithName` "error_handler" =
case findAttribute "error_handler" attrs of
Just (Attribute _ [ParamLit (StringLit s)]) ->
addCode (bind_ (funApp (toQualName s) [r_res]))
_ -> return ()
| isObj = return ()
| attrs `hasAttributeWithName` "usesgetlasterror" =
addCode (bind_ (funApp check2HR [r_res]))
| not (isHRESULT res) = return ()
| otherwise =
addCode (bind_ (funApp checkHR [r_res]))
where
r_res = var (outPrefix ++ idName f)
{-
Note: for method Ids, the renaming stage has transferred
all attributes from the result type onto the method Id, so
we don't need to fish out the result type attributes here.
-}
attrs = idAttributes f
\end{code}
In order to toss some of the input parameters over the fence, the stub
function may have to marshall 'em and store them in an external, non-moveable heap.
Before returning from the stub, we make sure that any such allocations are freed
up.
We currently don't assume the presence of a marshalling arena for the
allocation of marshalled values, so we cannot free the allocated memory
in one fell swoop.
\begin{code}
freeInParamStorage :: DependInfo -> [Param] -> Mm ()
freeInParamStorage dep_info ps = do
sequence (map freeParam ps)
return ()
where
freeParam p
-- special fall-thru case for [sequence, length_is()] - sigh.
| isJust dep_res && not has_seq = freeDependent i (findParamTy ps) deps
| attrs `hasAttributeWithName` "nofree" = return ()
| otherwise =
case (mbFreeType (paramType p)) of
Nothing -> return ()
Just e -> addCode (bind_ (funApply e [var (idName (paramId p))]))
where
i = paramId p
attrs = idAttributes i
has_seq = hasSeqAttribute attrs
dep_res = lookupDepender dep_info i
(Just deps) = dep_res
\end{code}
\begin{code}
isIsomorphicMethod :: String -> Result -> [Param] -> CgM (Maybe Bool)
isIsomorphicMethod nm res params = do
env <- getIsoEnv
case lookupEnv env nm of
Nothing -> return Nothing
Just alts ->
case break (match) alts of
(_,[]) -> return Nothing
(as,(flg,r,ps):bs) -> do
setIsoEnv (replaceElt env nm ((False,r,ps):as++bs))
return (Just flg)
where
len_params = length params
match (_,r,ps) =
resultType r == resultType res &&
len_params == length ps &&
all (\ (p1,p2) -> paramMode p1 == paramMode p2 &&
paramType p1 == paramType p2) -- ToDo: check attributes too.
(zip ps params)
\end{code}