module MarshallAbstract ( marshallAbstract ) where
import MarshallType
import CgMonad
import BasicTypes ( QualName, qName, CallConv(..) )
import Literal ( Literal(..) )
import AbstractH ( HDecl )
import AbsHUtils
import LibUtils
import Opts ( optHugs )
import Attribute
import CoreIDL
import CoreUtils ( mkHaskellTyConName, addrTy )
\end{code}
\begin{code}
marshallAbstract :: Id -> CgM HDecl
marshallAbstract i = do
ds <- mapM exportify decl_list
return (andDecls ds)
where
decl_list =
(if isFinalised then
( ( fin_name, fin_decl ) :)
else
id) $
(if isFinalised then
id
else
( ( f_name, f_tysig `andDecl` f_def) :))
[ ( m_name, m_tysig `andDecl` m_def)
, ( u_name, u_tysig `andDecl` u_def)
, ( w_name, w_tysig `andDecl` w_def)
, ( r_name, r_tysig `andDecl` r_def)
, ( s_name, s_tysig `andDecl` s_def)
, ( l_name, l_tysig `andDecl` l_def)
]
exportify (nm, d) = do
addExport (ieValue nm)
return d
attrs = idAttributes i
isFinalised = attrs `hasAttributeWithName` "finaliser"
free_routine =
case findAttribute "free" attrs of
Just (Attribute _ [ParamLit (StringLit s)]) -> mkVarName s
_ -> LibUtils.free
abs_nm = idOrigName i
con_name = mkHaskellTyConName abs_nm
name = mkVarName con_name
fin_name = finaliser
fin_decl
| optHugs = prim Cdecl (dname, Nothing, orig_fin_nm, Nothing)
fin_name (tyFunPtr (funTy (tyPtr t_ty) io_unit))
False [] (False,"void*")
| otherwise = extLabel orig_fin_nm fin_name (tyFunPtr (funTy (tyPtr t_ty) io_unit))
where
dname = ""
(finaliser, orig_fin_nm) =
case (findAttribute "finaliser" attrs) of
Just (Attribute _ [ParamLit (StringLit s)]) -> ("addrOf_" ++ idName i ++ '_':s, s)
_ -> let s = "no-finaliser" in (s,s)
ty_args =
case findAttribute "ty_args" attrs of
Just (Attribute _ [ParamLit (StringLit s)]) -> map tyVar (words s)
_ -> []
v = var "v"
vptr = var "ptr"
t_ty = tyCon con_name ty_args
prim_ty = tyPtr t_ty
b_ty
| isFinalised = tyForeignPtr t_ty
| otherwise = prim_ty
m_name = qName (prefix marshallPrefix name)
m_tysig = typeSig m_name (funTy t_ty (io b_ty))
m_def = funDef m_name [conPat (mkConName con_name) [varPat v]] m_rhs
m_rhs = ret v
u_name = qName (prefix unmarshallPrefix name)
u_tysig = typeSig u_name u_type
u_type
| isFinalised = funTy tyBool (funTy prim_ty (io t_ty))
| otherwise = (funTy prim_ty (io t_ty))
u_def = funDef u_name u_pats u_rhs
u_pats
| isFinalised = [patVar "finaliseMe__", varPat v]
| otherwise = [varPat v]
u_rhs
| isFinalised =
bind (funApp mkForeignObj [v, hCase (var "finaliseMe__")
[alt (conPat false []) (varName nullFinaliser)
,alt (conPat true []) (var finaliser)
]]) v $
ret (dataCon (mkConName con_name) [v])
| otherwise =
ret (dataCon (mkConName con_name) [v])
w_name = qName (prefix marshallRefPrefix name)
w_tysig = typeSig w_name w_ty
w_ty = funTy (tyPtr (tyPtr t_ty)) (funTy t_ty io_unit)
w_def = funDef w_name [ varPat vptr
, conPat (mkConName con_name) [varPat v]] w_rhs
w_rhs
| isFinalised = funApp w_fptr [vptr , v]
| otherwise = funApp w_ptr [vptr , v]
r_name = qName (prefix unmarshallRefPrefix name)
r_tysig = typeSig r_name r_ty
r_ty
| isFinalised = funTy tyBool (funTy (tyPtr t_ty) (io t_ty))
| otherwise = funTy (tyPtr t_ty) (io t_ty)
r_def = funDef r_name r_pats r_rhs
r_pats
| isFinalised = [patVar "finaliseMe__", varPat vptr]
| otherwise = [varPat vptr]
r_rhs
| isFinalised =
bind (funApp r_ptr [vptr]) v $
bind (funApp mkForeignObj [v, hCase (var "finaliseMe__")
[alt (conPat false []) (varName nullFinaliser)
,alt (conPat true []) (var finaliser)
]]) v $
ret (dataCon (mkConName con_name) [v])
| otherwise =
bind (funApp r_ptr [vptr]) v $
ret (dataCon (mkConName con_name) [v])
f_name = qName (prefix freePrefix name)
f_tysig = typeSig f_name (funTy t_ty io_unit)
f_def = funDef f_name [conPat (mkConName con_name) [varPat v]] f_rhs
f_rhs = funApp free_routine [v]
s_name = qName (prefix sizeofPrefix name)
s_tysig = typeSig s_name tyWord32
s_def = funDef s_name [] s_rhs
s_rhs = szType addrTy
l_name = qName (prefix "addrTo" name)
l_tysig = typeSig l_name (funTy anyTyPtr t_ty)
l_def = funDef l_name [varPat v] l_rhs
l_rhs
| isFinalised =
funApp (mkQVarName ioExts "unsafePerformIO")
[bind (funApp mkForeignObj [castPtr v, var finaliser]) v $
ret (dataCon (mkConName con_name) [v])]
| otherwise =
dataCon (mkConName con_name) [castPtr v]
w_ptr = prefix marshallRefPrefix (mkQVarName hdirectLib ptrName)
r_ptr = prefix unmarshallRefPrefix (mkQVarName hdirectLib ptrName)
w_fptr = prefix marshallRefPrefix (mkQVarName hdirectLib fptr)
\end{code}