%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Dec. 1st 2003 07:24 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
Generating marshalling code for Haskell COM servers.
\begin{code}
module MarshallServ ( cgServMethod, mkServVTBL, mkServMain ) where
import CoreIDL
import Attribute
import Literal ( iLit )
import CoreUtils
import AbstractH ( HDecl, Pat )
import PpAbstractH ( showAbstractH, ppType )
import AbsHUtils
import MarshallMethod
import MarshallMonad
import MarshallUtils
import MarshallType
import MarshallDep
import MarshallCore
import CgMonad
import BasicTypes
import LibUtils
import Opts
( optKeepHRESULT
, optExportListWithTySig
, optAnonTLB
, optUseStdDispatch
, optCom
)
import Monad ( when )
import Maybe
\end{code}
What it generates:
interface IA : IU {
HRESULT f ([in]int x);
};
primf :: Addr -> Int -> IO HRESULT
primf iptr x = do
v <- getIfaceState iptr
catch (f x v >> return s_OK)
(\ _ -> return s_FAIL)
mkIA_vtbl init_state = ....
\begin{code}
cgServMethod :: Id
-> Result
-> [Param]
-> Bool
-> Bool
-> CgM HDecl
cgServMethod i result params isSource isDisper = do
objFlag <- getInterfaceFlag
let
isObj = objFlag /= StdFFI
isDispSource =
isDisper ||
(isSource &&
case objFlag of { ComIDispatch _ -> True ; _ -> False })
return ( helpStringComment i `andDecl`
marshallMethod i isObj isDispSource result params
)
\end{code}
\begin{code}
marshallMethod :: Id
-> Bool
-> Bool
-> Result
-> [Param]
-> HDecl
marshallMethod i isObj isDispSource result params =
server_stub_tysig `andDecl` server_stub_def
where
m_name = mkHaskellVarName (name ++ "_meth")
name = idName i
r_ty = resultType result
server_stub_tysig = genTypeSig server_stub_name meth_ctxt server_stub_type
server_stub_type
| isDispSource = funTys [method_ty, tyList tyVariant, tyVar "objState"]
(io (tyMaybe tyVariant))
| otherwise =
case generaliseTys ((returnType stub_res_ty):stub_param_tys) of
((r:ts),mbc) -> mbCtxtTyApp mbc (funTys ts r)
server_stub_def = funDef server_stub_name server_stub_pats server_stub_rhs
server_stub_rhs
| isDispSource = stub_rhs
| isHRESULT result = funApp returnHR [stub_rhs]
| otherwise = stub_rhs
server_stub_pats
| isDispSource = [patVar m_name]
| otherwise = (patVar m_name) : in_stub_pats
server_stub_name
| isObj = mkPrimitiveName name
| otherwise = mkWrapperName name
obj_state_ty = uniqueTyVar "objState"
(method_ty,meth_ctxt) = (funTys ps m_res_ty, ctxt)
where
m_res_ty
| isObj = funTy obj_state_ty res
| otherwise = res
(m_ty, ctxt) = toHaskellMethodTy isPure (isDispSource || isObj) False Nothing params result
(ps,res) = splitFunTys m_ty
stub_param_tys = method_ty : stub_tys
(stub_tys_1, _) =
constrainIIDParams (\ p -> toHaskellBaseTy True (paramType p))
(\ p -> toHaskellBaseTy True (paramType p))
params
out_params
stub_tys = map (groundTyVars ) stub_tys_core
stub_tys_core
| isObj = toHaskellBaseTy True iUnknownTy : stub_tys_1
| otherwise = stub_tys_1
stub_res_ty = toHaskellBaseTy True r_ty
stub_res
| isObj = ret unit
| isHRESULT result = ret unit
| otherwise = ret meth_result_expr
stub_rhs
| isDispSource = dispatch_rhs
| otherwise = prim_stub_rhs
prim_stub_rhs =
runMm (Just name) param_names stub_res $ do
unmarshallDependents False False in_deps (findParamTy params)
unmarshallDependents False False inout_deps (findParamTy params)
marshallParams False True True (removeDependents in_deps real_ins)
marshallParams False True True (removeDependers (inout_deps++out_deps) real_inouts)
when isObj unmarshallIfacePointer
methCall (i{idName=m_name}) meth_result meth_params
when (not ignoreResult) (marshallResult i{idName=outPrefix++idName i} r_ty)
marshallDependents True True inout_deps (findParamTy params)
marshallParams True False True out_params
marshallParams True False True (removeDependers inout_deps real_inouts)
marshallDependents False
True
out_deps
(findParamTy params)
writeOutParams (removeDependees inout_deps outs)
dispatch_rhs = foldr unmarshallArg (apply m_name) params'
where
params'
| isHRESULT result || isVoidTy (resultType result) = params
| otherwise = params ++ [Param (mkId "the_res" "the_res" Nothing
[AttrMode Out, Attribute "retval" []])
Out Void Void False]
apply nm =
funApp (appendStr (show out_arity) applyName)
((funApply (var nm) in_args) : out_args)
out_arity = length out_args
out_args =
map toOutArgName $
filter (\ p -> paramMode p /= In) params'
where
toOutArgName p =
var $
case (paramMode p) of
InOut -> "out_" ++ mkHaskellVarName (idName (paramId p))
_ -> mkHaskellVarName (idName (paramId p))
in_args =
map (var.mkHaskellVarName.idName.paramId) $
filter (\ p -> paramMode p /= Out) params'
unmarshallArg p acc =
let
mode = paramMode p
t = paramType p
lam_pat = mkHaskellVarName (idName (paramId p))
(msheller, lams) =
case mode of
In | isIUnknownTy t -> (inIUnknownArgName, [patVar lam_pat])
| otherwise -> (inArgName, [patVar lam_pat])
Out
| isRetVal -> (retValName, [patVar lam_pat])
| otherwise -> (outArgName, [patVar lam_pat])
InOut -> (inoutArgName, [patVar lam_pat, patVar ("out_" ++ lam_pat)])
isRetVal = (idAttributes (paramId p)) `hasAttributeWithName` "retval"
in
contApply (varName msheller) (lam lams acc)
(meth_params, prim_params)
| isObj
= ( real_params ++ [obj_param]
, iptr_param:params
)
| otherwise
= ( real_params
, params
)
param_names = map (idName.paramId) params
in_stub_pats = map mkPat prim_params
where
mkPat p
| paramMode p == Out = patVar ("out_" ++ (idName (paramId p)))
| otherwise = patVar (idName (paramId p))
iptr_param = iPointerParam (idName i)
obj_param = objParam (idName i)
(results, ignoreResult) =
let results' = (real_outs ++ real_inouts)
in
case r_ty of
Void -> (results', True)
_ ->
case isHRESULT result && not optKeepHRESULT of
True -> (results', True)
_ -> (results' ++ [res_param], isSimpleTy r_ty)
(meth_result, meth_result_expr) =
case results of
[] -> (Nothing, unit)
_ -> (Just (tuplePat (map patVar res_names)), tup (map var res_names))
where
res_names = map (("res__"++).idName.paramId) results
isPure = (idAttributes i) `hasAttributeWithName` "pure"
returnType t = io t
res_param =
let p = mkParam (outPrefix ++ name) Out r_ty in
p{ paramOrigType=resultOrigType result
, paramId=(paramId p){idAttributes=idAttributes i}
}
out_params = map remPtr (removeDependents out_deps real_outs)
where
remPtr p
| not (isConstructedTy (nukeNames t') && not (isEnumTy t')) &&
not (isVariantTy t') =
case paramType p of
Pointer Unique isExp (Pointer _ _ x) -> p{paramType=Pointer Unique isExp x}
_ -> p{paramType=t'}
| otherwise = p
where
t' = removePtr (paramType p)
(pars, ins,outs,inouts,_) = binParams params
(real_params', _) = findParamDependents False pars
(real_ins, in_deps) = findParamDependents False ins
(real_outs, out_deps) = findParamDependents False outs
(real_inouts, inout_deps) = findParamDependents False inouts
real_params = map jiggleInOut real_params'
jiggleInOut p
| paramMode p == InOut = p{paramId=(paramId p){idName= "in__" ++ idName (paramId p)}}
| otherwise = p
\end{code}
\begin{code}
mkServVTBL :: Id -> Bool -> Bool -> [InterfaceDecl] -> CgM HDecl
mkServVTBL iface_id isDispSource justVTBL decls =
getDeclName $ \ mname -> do
dname <- getDllName
let
meths = filter isMethod decls
mkFFIDecl m = do
let res = methResult m
(_, prim_decl,mb_prim) <-
primDecl True True True
(declId m) dname mname
(methCallConv m)
(resultType res)
(methParams m)
return (prim_decl, mb_prim)
ffi_decls
| isDispSource = return []
| otherwise = mapM mkFFIDecl meths
fs_stuff <- ffi_decls
let
(fs, prim_nms) = unzip fs_stuff
mk_vtbl =
genTypeSig mk_vtbl_nm (listToMaybe (catMaybes ctxts))
(funTys meth_tys mk_vtbl_res_ty) `andDecl`
funDef mk_vtbl_nm mk_vtbl_pats mk_vtbl_rhs
mk_vtbl_pats = map (patVar.mkHaskellVarName.idName.declId) meths
mk_vtbl_nm = "mk" ++ qName (vtblName iface_id)
mk_vtbl_res_ty = io (mkTyCon comVTableTy [iid_ty, iface_ty])
mk_vtbl_args = zipWith (\ _ x -> var ("meth_arg"++show x)) meths [(0::Int)..]
mk_vtbl_rhs =
foldr
(uncurry binder)
(funApp vtbl_creator [(hList mk_vtbl_args)])
(zip (zipWith export_prim meths (prim_nms ++ repeat Nothing)) mk_vtbl_args)
where
binder
| isDispSource = \ m v n -> hLet v m n
| otherwise = bind
vtbl_creator
| isDispSource = createDispVTable
| otherwise = createComVTable
iface_ty = uniqueTyVar "objState"
iid_ty = tyQCon (idModule iface_id)
(idName iface_id) [tyUnit]
(meth_tys, ctxts) =
unzip $
map (\ m -> toHaskellMethodTy False
True
False
(Just iface_ty) (methParams m)
(methResult m))
meths
export_prim m mb_prim_nm
| isDispSource = funApp mkDispMethod [ stringLit f_nm, dispid, wrap_up ]
| otherwise = funApply (var prim_nm) [wrap_up]
where
prim_nm =
case mb_prim_nm of
Just x -> x
_ -> mkPrimExportName nm
i = declId m
f_nm = idOrigName i
dispid =
case getDispIdAttribute (idAttributes i) of
Nothing -> lit (iLit (0::Int))
Just il -> integerLit il
wrap_up = funApply (var (mkPrimitiveName nm))
[var (mkHaskellVarName nm)]
nm = idName i
addExport (ieValue mk_vtbl_nm)
if justVTBL then
return mk_vtbl
else do
return (andDecls (mk_vtbl:fs))
vtblName :: Id -> QualName
vtblName i = mkQualName (idModule i) (idName i ++ "_vtbl")
\end{code}
\begin{code}
methCall :: Id -> Maybe Pat -> [Param] -> Mm ()
methCall f mb_res params =
addCode $
case mb_res of
Nothing -> bind_ f_app
Just p
| isPure -> \ e -> hCase f_app [alt p e]
| otherwise -> genBind f_app p
where
isPure = (idAttributes f) `hasAttributeWithName` "pure"
f_app = funApp (mkVarName meth_name) args
args = map (var.idName.paramId) params
meth_name = mkHaskellVarName (idName f)
unmarshallIfacePointer :: Mm ()
unmarshallIfacePointer =
addCode (bind (funApp getIfaceState [var iptr]) obj)
where
obj = var "obj"
marshallResult :: Id -> Type -> Mm ()
marshallResult _ Void = return ()
marshallResult i ty =
addCode (bind (funApply (marshallType proxyMarshallInfo ty) [nm]) nm)
where
nm = var ("res__" ++ idName i)
\end{code}
\begin{code}
writeOutParams :: [Param] -> Mm ()
writeOutParams params = do
sequence (map writeOut params)
return ()
where
writeOut p
| isVoidTy ty = return ()
| otherwise = addCode (bind_ wOut)
where
i = paramId p
ty = paramType p
ty' = removeNames (removePtr ty)
nm = idName i
resV n = var ("res__" ++ n)
wOut
| isSimpleTy ty'
= funApply (refMarshallType proxyMarshallInfo ty') [var ("out_"++nm), resV nm]
| isEnumTy ty' || isBoolTy ty'
= funApply (refMarshallType proxyMarshallInfo intTy) [var ("out_"++nm), resV nm]
| otherwise
= case ty' of
Name "VARIANT_BOOL" _ _ _ _ _ | optCom ->
funApply (refMarshallType proxyMarshallInfo int16Ty) [var ("out_"++nm), resV nm]
_ -> funApp w_mshall [castPtr (var ("out_"++nm)), resV nm]
where
w_mshall = prefix marshallRefPrefix (mkQVarName hdirectLib ptrKind)
ptrKind
| isFinalised = fptr
| otherwise = "Ptr"
isFinalised = isFOTy (toHaskellBaseTy False ty')
\end{code}
What's generated for a coclass decl:
\begin{code}
mkServMain :: String -> Id -> [CoClassDecl] -> CgM HDecl
mkServMain lib_nm i cdecls = do
mapM_ addExp exports
return ( register_class `andDecl`
new_instance `andDecl`
component_info_def `andDecl`
vtbl_decls `andDecl`
ifaces_decl )
where
addExp (nm,ty)
| optExportListWithTySig = addExportWithComment nm (":: " ++ showAbstractH (ppType ty))
| otherwise = addExport nm
exports = [ (ieValue component_info_nm, component_info_ty) ]
class_name = idName i
clsid_nm = mkCLSIDName class_name
libid_nm = mkLIBIDName lib_nm
implemented_ifaces = filter nonSourceIface cdecls
nonSourceIface d = not ((idAttributes (coClassId d)) `hasAttributeWithName` "source")
component_info_nm = "componentInfo"
component_info_ty = mkTyConst componentInfo
component_info_tysig = typeSig component_info_nm component_info_ty
component_info_def =
component_info_tysig `andDecl`
valDef component_info_nm component_info_rhs
component_info_rhs =
(if usesTlb then
\ x -> funApp hasTypeLib [x]
else
id) $
funApp mkComponentInfo
[ var clsid_nm
, var register_class_nm
, var new_instance_nm
]
register_class =
register_class_sig `andDecl`
register_class_def
register_class_sig = typeSig register_class_nm register_class_ty
register_class_nm = "register_" ++ class_name
register_class_ty = funTys [tyString, tyBool] io_unit
register_class_def =
funDef register_class_nm [wildPat, wildPat] register_class_rhs
register_class_rhs = ret unit --ToDo.
new_instance =
new_instance_sig `andDecl`
new_instance_def
new_instance_sig = typeSig new_instance_nm new_instance_ty
new_instance_nm = "new" ++ class_name
new_instance_ty =
funTy tyString $
funTy (io_unit) $
funTy (mkTyCon iID [mkTyCon iUnknown [tyVar "iid"]])
(io (mkTyCon iUnknown [tyVar "iid"]))
component_mod = Just (idName i)
component_new = qvar component_mod "new"
new_instance_def = funDef new_instance_nm
[ patVar "dll_path"
, patVar "finaliser"
, patVar "iid"
]
new_instance_rhs
new_instance_rhs =
bind component_new obj_state $
funApp createComInst [dll_path, obj_state, var "finaliser", var ifaces_nm, var "iid"]
dll_path = var "dll_path"
obj_state = var "obj_state"
ifaces_nm = "ifaces_" ++ class_name
objStateTy = tyQConst component_mod "State"
ifaces_decl =
ifaces_ty_sig `andDecl`
ifaces_def
ifaces_ty = tyList (mkTyCon comInterfaceTy [objStateTy])
ifaces_ty_sig = typeSig ifaces_nm ifaces_ty
ifaces_def =
valDef ifaces_nm
ifaces_rhs
usesTlb = not optUseStdDispatch && any derivesFromIDispatch implemented_ifaces
ifaces_rhs = hList (map mkIface implemented_ifaces)
mkIface d
| isDual = funApp mkDualInterface l_args
| isAuto = funApp mkDispInterface l_args
| otherwise = funApp mkComInterface args
where
isDual = (idAttributes cid) `hasAttributeWithName` "dual"
isAuto = derivesFromIDispatch d
tlb_arg
| optAnonTLB || optUseStdDispatch = nothing
| otherwise = just (var libid_nm)
l_args = (tlb_arg : args)
args = [qvar md ("iid" ++nm), var (vtbl_nm ++ "_vtbl")]
cid = coClassId d
md = idModule cid
nm = idName cid
vtbl_nm = mkHaskellVarName nm
vtbl_decls = andDecls (map mk_vtbl implemented_ifaces)
mk_vtbl d =
typeSig vtbl_nm (mkTyCon comVTableTy [iid_ty, objStateTy]) `andDecl`
valDef vtbl_nm vtbl_rhs
where
iid_ty = tyQCon (idModule (coClassId d))
(idName (coClassId d)) [tyUnit]
vtbl_nm_raw = vtblName (coClassId d)
vtbl_nm = mkHaskellVarName (qName vtbl_nm_raw)
vtbl_rhs = funApp uPerformIO [funApp (prefix "mk" vtbl_nm_raw) meths]
meths =
case coClassDecl d of
Nothing -> error "Stuck"
Just dcl ->
let
decls =
case dcl of
DispInterface{dispExpandedFrom=ii} | isJust ii -> declDecls (fromJust ii)
_ -> declDecls dcl
the_meths = filter (isMethod) decls
in
map ((qvar component_mod).mkHaskellVarName.idName.declId) the_meths
\end{code}