hdirect-0.21.0: src/MarshallType.lhs
%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Jun. 10th 2003 12:17 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
MarshallType provides the following:
- converting IDL types to Haskell ones.
- functions for generating code that (un)marshalls a value
of an IDL type.
- marshalling dependent parameter types
\begin{code}
module MarshallType
(
marshallType
, unmarshallType
, refMarshallType
, refUnmarshallType
, szType
, allocPointerTo
, freeType
, mbFreeType
, needsFreeing
, coreToHaskellExpr
, coerceTy
, coerceToInt -- :: Expr -> Haskell.Expr
) where
import Prelude hiding ( mod )
import BasicTypes
import Attribute
import Literal
import LibUtils
import Utils ( mapFromMb, trace, notNull )
import qualified AbstractH as Haskell ( Expr(..) )
--import qualified PpAbstractH as PPHaskell ( showAbstractH )
import AbsHUtils
import CoreIDL
import CoreUtils
import PpCore ( showCore, ppType )
import Maybe ( fromMaybe, isJust, fromJust )
import MarshallCore
import MarshallMonad
import Opts ( optHaskellToC, optLongLongIsInteger,
optCorba, optCom, optNoWideStrings,
optNoDerefRefs
)
import TypeInfo ( TypeInfo(..) )
\end{code}
%*
%
<sect>Marshalling types
%
%*
From a given IDL type t we may need to generate calls to functions
that implement various marshalling operations over type t:
- marshall, by-value and by-reference
- unmarshall, by-value and by-reference
- size of
- allocate
- release/free
The following functions can be used to do this:
\begin{verbatim}
marshallType :: MarshallInfo -> Type -> Haskell.Expr
refMarshallType :: MarshallInfo -> Type -> Haskell.Expr
unmarshallType :: MarshallInfo -> Type -> Haskell.Expr
refUnmarshallType :: MarshallInfo -> Type -> Haskell.Expr
szType :: MarshallInfo -> Type -> Haskell.Expr
-- alloc storage to hold a (fixed size) value of a particular type,
-- returning a pointer to it.
allocPointerTo :: Type -> Haskell.Expr
\end{verbatim}
\begin{code}
marshallType :: MarshallInfo -> Type -> Haskell.Expr
marshallType mInfo t =
case t of
Array at []
| forRef mInfo -> funApp w_list [ varName false, szType at, refMarshallType mInfo at ]
| otherwise -> funApp m_list [ szType at, refMarshallType mInfo{forRef=True} at ]
Array (Char _) [e]
| forRef mInfo -> funApp w_bstring [ varName false, coreToHaskellExpr e ]
Array at [e]
| forRef mInfo -> funApp w_blist [ szType at
, coreToHaskellExpr e
, refMarshallType mInfo{forRef=True} at
]
| otherwise -> funApp m_blist
[ szType at
, coreToHaskellExpr e
, refMarshallType mInfo{forRef=True} at
]
Array at [mi,ma] ->
funApp m_blist [ szType at
, binOp Sub (coreToHaskellExpr ma)
(coreToHaskellExpr mi)
, refMarshallType mInfo{forRef=True} at
]
Pointer _ _ ty | isVoidTy ty -> varName prelReturn
Pointer Ptr _ ty
| (isConstructedTy (nukeNames ty) && isReferenceTy ty) -> varName prelReturn
Pointer pt isExp (Iface nm mod _ attrs _ inh) ->
case pt of
Unique | optCom && isExp -> funApp marshallMaybe [ varName m_iptr, varName nullFO ]
| optHaskellToC && isExp -> funApp marshallMaybe
[ varName m_ip
, varName $
if attrs `hasAttributeWithName` "finaliser" then
nullFO
else
nullPtr
]
_ ->
case inh of
[] | optHaskellToC -> varName m_ip
| otherwise -> varName m_iptr
(x:_)
| optCorba -> varName (prefix marshallPrefix (fst x))
| optCom ||
qName (fst x) == "IUnknown" -> varName m_iptr
| otherwise -> varName (prefix marshallPrefix (fst x))
where
m_ip = prefix marshallPrefix (mkQVarName mod nm)
Pointer pt _ (Name _ _ _ _ _ (Just ti))
| pt /= Ptr && is_pointed ti ->
let
mshaller
| forInOut mInfo && finalised ti = varName (copy_marshaller ti)
| otherwise = varName (marshaller ti)
null_elt
| forInOut mInfo && finalised ti = varName nullPtr
| finalised ti = varName nullFO
| otherwise = varName nullPtr
in
case pt of
Unique -> funApp marshallMaybe [ mshaller, null_elt ]
_ -> mshaller
Pointer pt _ ty
| isFunTy ty && pt /= Ptr -> marshallType mInfo ty
| forInOut mInfo && forProxy mInfo -> refMarshallType mInfo t
| otherwise ->
case pt of
Ptr -> varName prelReturn
Ref -> funApp m_ref [ allocPointerTo ty, refMarshallType mInfo{forRef=False} ty ]
Unique -> funApp m_unique [ allocPointerTo ty, refMarshallType mInfo{forRef=False} ty ]
Void -> varName prelReturn -- this shouldn't really happen.
String _ isUnique _
| isUnique -> funApp marshallMaybe [varName m_string, varName nullPtr]
| otherwise -> varName m_string
Sequence ty mbSz mbTerm
-> funApp m_sequence [ refMarshallType mInfo{forRef=False} ty
, terminatorElt True mbTerm ty
, szType ty
, case mbSz of
Nothing -> nothing
Just x -> just (coreToHaskellExpr x)
]
SafeArray{} -> varName m_safearray
WString isUnique _
| isUnique -> funApp marshallMaybe [varName m_wstring, varName nullPtr]
-- | isUnique -> funApp marshallMaybe [varName m_wstring, varName nullFO]
| otherwise -> varName m_wstring
Bool -> varName m_bool
Enum{} -> varName m_enum32
Name _ _ _ _ _ (Just ti)
| forInOut mInfo && finalised ti -> varName (copy_marshaller ti)
| otherwise -> varName (marshaller ti)
Name _ _ _ _ (Just ty@Enum{}) _ -> marshallType mInfo ty
Name _ _ _ _ (Just ty@(Name{})) _ -> marshallType mInfo ty
Name nm _ mod _ (Just (Struct i [f] _)) _
| isSimpleTy (fieldType f) ||
((idAttributes i) `hasAttributeWithName` "hs_newtype")
-> qvar mod (marshallPrefix ++ nm)
Name nm _ mod _ (Just ty) _
| isConstructedTy (nukeNames ty) && not (isFunTy ty) -> funApp m_ref [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
| isFunTy ty -> qvar mod (marshallPrefix ++ nm)
| otherwise -> marshallType mInfo ty
Struct i fs _
| length fs == 1 && isSimpleTy (fieldType (head fs)) &&
not ((idAttributes i) `hasAttributeWithName` "hs_newtype")
-> qvar (idModule i) (marshallPrefix ++ idName i)
| otherwise -> funApp m_ref [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
Union{} -> funApp m_ref [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
UnionNon{} -> funApp m_ref [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
CUnion{} -> funApp m_ref [ allocPointerTo t, refMarshallType mInfo{forRef=False} t ]
Integer LongLong isSigned
| optLongLongIsInteger -> varName (m_integer isSigned)
Iface{} -> marshallType mInfo (Pointer Ref True t)
_ -> let nm = mkMarshaller marshallPrefix t in
varName nm
where
m_bool = libImport bool
m_string = libImport stringName
m_list = libImport list
m_blist = libImport blist
m_ref = libImport ref
m_unique = libImport unique
m_sequence = libImport "Sequence"
m_safearray
| forProxy mInfo = prefix marshallPrefix sAFEARRAY
| otherwise = prefix marshallPrefix (mkQVarName autoLib safearray)
w_list = prefix marshallRefPrefix (mkQVarName hdirectLib list)
w_bstring = prefix marshallRefPrefix (mkQVarName hdirectLib bstring)
w_blist = prefix marshallRefPrefix (mkQVarName hdirectLib blist)
m_integer isSigned
| isSigned = libImport integer
| otherwise = libImport ('U':integer)
m_enum32 = libImport enum32
m_iptr = prefix marshallPrefix iUnknown
m_wstring
| optNoWideStrings = wideImport wstring2
| otherwise = wideImport wstring
libImport nm = prefix marshallPrefix (mkQVarName hdirectLib nm)
wideImport nm = prefix marshallPrefix (mkQVarName wStringLib nm)
terminatorElt :: Bool -> Maybe Expr -> Type -> Haskell.Expr
terminatorElt forMarshalling mbTerm ty
| forMarshalling = lam [patVar "x"] $
funApp (prefix marshallRefPrefix termTyName)
[ var "x"
, termVal
]
| otherwise = lam [patVar "ptr"] $
bind (funApp (prefix unmarshallRefPrefix termTyName) [var "ptr"])
(var "dx")
(ret (infixOp (var "dx") eqName termVal))
where
(termVal, termTyName) =
case ty of
Char{} -> (Haskell.Lit (CharLit '\0'), mkQVarName hdirectLib "Char")
Integer sz signed ->
case mbTerm of
Just e -> (coreToHaskellExpr e, deTyCon $ mkIntTy sz signed)
_ -> (coreToHaskellExpr (Lit (iLit (0::Int))), deTyCon $ mkIntTy sz signed)
_ -> (varName nullPtr, mkQVarName hdirectLib "Ptr")
\end{code}
\begin{code}
unmarshallType :: MarshallInfo -> Type -> Haskell.Expr
unmarshallType mInfo ty =
case ty of
Array (Char _) [] -> varName u_string
{-
Handling open arrays when unmarshalling is tricky
if you haven't got any information on the size of the
thing. Nontheless, we represent open arrays as lists,
since there's no trouble marshalling a list into an
(open) array - it's this other way which is troublesome.
So..we emit code which tries to marshall *one* element
from the array here. Elsewhere we emit a warning message
that the unmarshaller for a struct containing open arrays
isn't 100% cool. The fix is either to use [size_is()] or
manually tweak the gen'ed code.
ToDo: add support for the notion of zero terminated vectors?
-}
Array t [] -> funApp u_single [ refUnmarshallType mInfo{forRef=True} t ]
Array (Char _) [e] ->
funApp u_bstring [ coreToHaskellExpr e ]
Array t [e]
| doFree mInfo ->
funApp doThenFree
[ freeType ty
, funApp u_list [ szType t
, var "0"
, coreToHaskellExpr e
, refUnmarshallType mInfo{forRef=True} t
]
]
| otherwise ->
funApp u_list [ szType t
, var "0"
, coreToHaskellExpr e
, refUnmarshallType mInfo{forRef=True} t
]
Array t [mi,ma]
| doFree mInfo ->
funApp doThenFree
[ freeType ty
, funApp u_list [ szType t
, coreToHaskellExpr mi
, coreToHaskellExpr ma
, refUnmarshallType mInfo{forRef=True} t
]
]
| otherwise ->
funApp u_list [ szType t
, coreToHaskellExpr mi
, coreToHaskellExpr ma
, refUnmarshallType mInfo{forRef=True} t
]
String _ isUnique _
| doFree mInfo -> funApp doThenFree [ freeType ty, uString ]
| otherwise -> uString
where
uString
| isUnique = funApp readMaybe [ varName u_string ]
| otherwise = varName u_string
Sequence t mbSz mbTerm ->
funApp u_sequence [ refUnmarshallType mInfo{forRef=False} t
, terminatorElt False mbTerm t
, szType t
, case mbSz of
Nothing -> nothing
Just x -> just (coreToHaskellExpr x)
]
WString isUnique _
| doFree mInfo -> funApp doThenFree [ freeType ty, uString ]
| otherwise -> uString
where
uString
| isUnique = funApp readMaybe [ varName u_wstring ]
| otherwise = varName u_wstring
Pointer pt isExp t@(Iface nm mod _ attrs _ inh) ->
case pt of -- see marshallType comment re: raw interface ptrs.
Ptr | optCom -> u_ipointer
Unique | (optCom || optHaskellToC) && isExp ->
if forRef mInfo then
funApp u_unique [ refUnmarshallType mInfo{forRef=False} t ]
else
funApp u_unique [ unmarshallType mInfo t ]
_ ->
case inh of
[] | optCom -> u_ipointer
| optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
funApp u_ip [ lit (BooleanLit (not (forProxy mInfo))) ]
| otherwise -> varName u_ip
(x:_)
| optCorba -> varName (prefix unmarshallPrefix (fst x))
| optCom || qName (fst x) == "IUnknown" ->
if forRef mInfo then
refUnmarshallType mInfo{forRef=False} ty
else
u_ipointer
| optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
funApply (varName (prefix unmarshallPrefix (fst x)))
[ lit (BooleanLit (not (forProxy mInfo))) ]
| otherwise -> varName (prefix unmarshallPrefix (fst x))
where
u_ip = prefix unmarshallPrefix (mkQVarName mod nm)
Pointer _ _ (Name _ _ _ _ _ (Just ti))
| is_pointed ti ->
if finalised ti then
funApply (varName (unmarshaller ti)) [lit (BooleanLit (not (forProxy mInfo))) ]
else
varName (unmarshaller ti)
Pointer _ _ Void -> varName prelReturn
Pointer pt _ t ->
case pt of
Ptr
| isIfacePtr t ->
if forRef mInfo then
refUnmarshallType mInfo{forRef=False} t
else
u_ipointer
| isPointerTy t && doFree mInfo -> funApp doThenFree
[ freeType ty
, refUnmarshallType mInfo{forRef=False} t
]
| isPointerTy t -> refUnmarshallType mInfo{forRef=False} t
| otherwise -> varName prelReturn
Ref
| doFree mInfo -> funApp doThenFree [ freeType ty
, refUnmarshallType mInfo{forRef=False} t
]
| otherwise -> refUnmarshallType mInfo{forRef=False} t
Unique
| isIfacePtr t ->
if forRef mInfo then
funApp u_unique [ refUnmarshallType mInfo{forRef=False} (getIfaceTy ty) ]
else
funApp u_unique [ unmarshallType mInfo (getIfaceTy ty) ]
| doFree mInfo -> funApp doThenFree [ freeType ty
, funApp u_unique
[ refUnmarshallType mInfo{forRef=False} t ]
]
| otherwise -> funApp u_unique [ refUnmarshallType mInfo{forRef=False} t ]
Void -> varName prelReturn
Bool -> varName u_bool
Name _ _ _ _ _ (Just ti) {- not (is_pointed ti) -} ->
if finalised ti then
funApply (varName (unmarshaller ti)) [lit (BooleanLit (not (forProxy mInfo))) ]
else
varName (unmarshaller ti)
Name _ _ _ _ (Just t@Enum{}) _ -> unmarshallType mInfo t
Name _ _ _ _ (Just t@(Name{})) _ -> unmarshallType mInfo t
Name nm _ mod _ (Just (Struct i [f] _)) _
| isSimpleTy (fieldType f) ||
((idAttributes i) `hasAttributeWithName` "hs_newtype")
-> qvar mod (unmarshallPrefix ++ nm)
Name _ _ _ _ (Just t) _
| isConstructedTy (nukeNames t) -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
Struct i fs _
| (length fs == 1 && isSimpleTy (fieldType (head fs))) ||
((idAttributes i) `hasAttributeWithName` "hs_newtype")
-> qvar (idModule i) (unmarshallPrefix ++ idName i)
| otherwise -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
Union{} -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
UnionNon{} -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
CUnion{} -> refUnmarshallType mInfo{forRef=False} (Pointer Ref True ty)
Enum{} -> varName u_enum32
Iface{} -> unmarshallType mInfo (Pointer Ptr True ty)
SafeArray{} -> u_safearray
Integer LongLong isSigned
| optLongLongIsInteger -> varName (u_integer isSigned)
_ -> let nm = mkMarshaller unmarshallPrefix ty in
varName nm
where
u_bool = libImport bool
u_string = libImport stringName
u_list = libImport list
u_bstring = libImport bstring
u_unique = libImport unique
u_single = libImport "Single"
u_sequence = libImport "Sequence"
u_safearray
| forProxy mInfo = funApply (varName (prefix unmarshallPrefix sAFEARRAY)) [ lit (BooleanLit False) ]
| forStruct mInfo = funApply (varName (prefix unmarshallPrefix sAFEARRAY)) [ lit (BooleanLit False) ]
| otherwise = varName (prefix marshallPrefix (mkQVarName autoLib safearray))
u_integer isSigned
| isSigned = libImport integer
| otherwise = libImport ('U':integer)
u_enum32 = libImport enum32
u_iptr = prefix unmarshallPrefix iUnknown
u_ipointer
| forInOut mInfo = varName (prefix unmarshallPrefix iUnknownFO)
| otherwise = funApp u_iptr [ lit (BooleanLit (forProxy mInfo)) ]
u_wstring
| optNoWideStrings = wStringImport wstring2
| otherwise = wStringImport wstring
libImport nm = prefix unmarshallPrefix (mkQVarName hdirectLib nm)
wStringImport nm = prefix unmarshallPrefix (mkQVarName wStringLib nm)
\end{code}
\begin{code}
refMarshallType :: MarshallInfo -> Type -> Haskell.Expr
refMarshallType mInfo t =
case t of
Array (Char _) [e] -> funApp w_bstring [ varName true, coreToHaskellExpr e ]
Array at [e] ->
funApp w_blist
[ szType at
, coreToHaskellExpr e
, refMarshallType mInfo{forRef=False} at
]
Array at [mi, ma] ->
funApp w_blist
[ szType at
, binOp Sub (coreToHaskellExpr ma)
(coreToHaskellExpr mi)
, refMarshallType mInfo{forRef=False} at
]
Array at [] -> funApp w_list [ varName false
, szType at
, refMarshallType mInfo{forRef=False} at
]
SafeArray{} -> varName w_safearray
String _ isUnique _
| isUnique -> funApp writeMaybe [ varName w_string ]
| otherwise -> funApp w_string [ varName true ]
WString isUnique _
| isUnique -> funApp writeMaybe [ varName w_string ]
| otherwise -> varName w_wstring
Sequence ty mbSz mbTerm ->
funApp w_sequence [ varName true
, refMarshallType mInfo{forRef=False} ty
, terminatorElt True mbTerm ty
, szType ty
, case mbSz of
Nothing -> nothing
Just x -> just (coreToHaskellExpr x)
]
{- Hmm..I'm not sure what is the right thing here - include the
Maybe or not. If the Maybe type is used, then MarshallCore.toHaskellTy
will need to change accordingly. -}
Pointer Unique isExp ty
| forRef mInfo &&
(optCom || optHaskellToC) &&
isExp &&
isIfaceTy ty -> funApp writeMaybe [ w_ip ]
where
(Iface nm mod _ _ _ _) = getIfaceTy ty
w_ip
| optHaskellToC = varName (prefix marshallRefPrefix (mkQVarName mod nm))
| otherwise = funApp w_iptr [w_iptr_arg]
Pointer _ _ (Iface nm mod _ _ _ inh) ->
case inh of
[] | not optHaskellToC -> funApp w_iptr [ w_iptr_arg ]
| otherwise -> varName w_ip
(x:_)
| optCorba -> varName (prefix marshallRefPrefix (fst x))
| not optHaskellToC -> funApp w_iptr [ w_iptr_arg ]
| otherwise -> varName (prefix marshallRefPrefix (fst x))
where
w_ip = prefix marshallRefPrefix (mkQVarName mod nm)
Pointer pt _ (Name _ _ _ _ _ (Just ti))
| pt /= Ptr && is_pointed ti ->
case pt of
Unique ->
if finalised ti then
funApp writeMaybe [ varName (ref_marshaller ti) ]
else
funApp writeMaybe [ varName (ref_marshaller ti) ]
_ -> varName (ref_marshaller ti)
Pointer Ptr _ (Name _ _ _ (Just as) _ _)
| as `hasAttributeWithName` "foreign" -> varName w_fptr
Pointer _ _ ty | isVoidTy ty -> varName w_ptr
Pointer pt _ ty
| isIfaceTy ty -> refMarshallType mInfo{forRef=False}
(Pointer Ref True (getIfaceTy ty))
| otherwise ->
case pt of
Ptr -> varName w_ptr
Ref
| optNoDerefRefs -> funApp w_ref [ allocPointerTo ty, refMarshallType mInfo ty ]
| otherwise -> refMarshallType mInfo ty
Unique -> funApp w_unique [ allocPointerTo ty, refMarshallType mInfo ty ]
Void -> varName w_addr
Bool -> varName w_bool
CUnion i _ _ ->
let
nm = mkMarshaller marshallRefPrefix t
sw =
case (getSwitchIsAttribute (idAttributes i)) of
Just e | notNull fs ->
let v = head fs in var ("write_tag_" ++ v)
where
fs = findFreeVars e
_ -> var ("where_do_I_put_the_tag")
in
funApply (varName nm) [sw]
Iface{} -> refMarshallType mInfo (Pointer Ref True t)
Name _ _ _ _ _ (Just ti) | not (is_pointed ti) -> varName (ref_marshaller ti)
Name _ _ _ _ (Just ty@Enum{}) _ -> refMarshallType mInfo ty
Name _ _ _ _ (Just ty@(Name{})) _ -> refMarshallType mInfo ty
Enum{} -> varName w_enum32
Name nm _ mod _ (Just ty) _
| not is_cons_type -> refMarshallType mInfo ty
| not (forStruct mInfo) && isNonEncUnionTy (removeNames ty) -> funApply w_ty w_args
| otherwise ->
if isFinalisedType True ty then
funApply w_ty [ w_iptr_arg ]
else
w_ty
where
is_cons_type = isConstructedTy (nukeNames ty)
w_ty = varName (prefix marshallRefPrefix (mkQVarName mod nm))
w_args
| isFinalisedType True ty = [ w_iptr_arg, write_tag ]
| otherwise = [ write_tag ]
write_tag = lam [wildPat] (ret unit)
Integer LongLong isSigned
| optLongLongIsInteger -> varName (w_integer isSigned)
_ -> varName (mkMarshaller marshallRefPrefix t)
where
w_bool = libImport bool
w_string = libImport stringName
w_blist = libImport blist
w_list = libImport list
w_bstring = libImport bstring
w_ptr = libImport ptrName
w_fptr = libImport fptr
w_ref = libImport ref
w_unique = libImport unique
w_addr = libImport ptrName
w_sequence = libImport "Sequence"
w_safearray
| forStruct mInfo = prefix marshallRefPrefix sAFEARRAY
| otherwise = prefix marshallRefPrefix (mkQVarName autoLib safearray)
w_integer isSigned
| isSigned = libImport integer
| otherwise = libImport ('U':integer)
w_enum32 = libImport enum32
w_iptr = prefix marshallRefPrefix iUnknown
w_iptr_arg
| forStruct mInfo = var "addRefMe__"
| otherwise = lit (BooleanLit (forProxy mInfo))
w_wstring
| optNoWideStrings = wStringImport wstring2
| otherwise = wStringImport wstring
libImport nm = prefix marshallRefPrefix (mkQVarName hdirectLib nm)
wStringImport nm = prefix marshallRefPrefix (mkQVarName wStringLib nm)
refUnmarshallType :: MarshallInfo -> Type -> Haskell.Expr
refUnmarshallType mInfo t =
case t of
Array (Char _) [e] -> funApp r_bstring [ coreToHaskellExpr e ]
-- this is the identity unmarshallers under the assumption
-- that the array ref. type is used in conjunction with
-- a 'dependent' attribute (size_is() et. al). This may
-- not always be the case, so this is may cause breakage.
--
-- 3/99: Changed to instead do something a bit saner, but
-- tell the user of the problem.
Array ty []
-> trace ("warning: unmarshalling incomplete array type decl, " ++ showCore (ppType t) ++
" , don't know how big.\n Assuming of length 1. " ) $
funApp r_blist
[ szType t
, lit (iLit (1::Int))
, refUnmarshallType mInfo{forRef=False} ty
]
Array ty [e] ->
funApp r_blist
[ szType ty
, coreToHaskellExpr e
, refUnmarshallType mInfo{forRef=False} ty
]
String _ isUnique _
| isUnique -> funApp readMaybe [ varName r_string ]
| otherwise -> varName r_string
WString isUnique _
| isUnique -> funApp readMaybe [ varName r_wstring ]
| otherwise -> varName r_wstring
SafeArray _ -> r_safearray
Sequence ty mbSz mbTerm ->
funApp r_sequence [ refUnmarshallType mInfo{forRef=False} ty
, terminatorElt False mbTerm ty
, szType ty
, case mbSz of
Nothing -> nothing
Just x -> just (coreToHaskellExpr x)
]
Pointer Unique isExp ty
| forRef mInfo &&
(optCom || optHaskellToC) &&
isExp &&
isIfaceTy ty -> funApp r_unique [ u_ip ]
where
(Iface nm mod _ attrs _ _) = getIfaceTy ty
u_ip
| optHaskellToC =
funApp (prefix unmarshallRefPrefix (mkQVarName mod nm))
(if attrs `hasAttributeWithName` "finaliser" then
[ lit (BooleanLit (not (forProxy mInfo))) ]
else
[{-empty-}]
)
| otherwise = funApp u_iptr [ final_arg ]
Pointer _ _ (Iface nm mod _ attrs _ inh) ->
case inh of
[] | optCom -> funApp r_iptr [ final_arg ]
| optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
funApply r_ip [ lit (BooleanLit (not (forProxy mInfo))) ]
| otherwise -> r_ip
(x:_)
| optCorba -> varName (prefix unmarshallRefPrefix (fst x))
| optCom -> funApp r_iptr [ final_arg ]
| optHaskellToC && attrs `hasAttributeWithName` "finaliser" ->
funApply (varName (prefix unmarshallRefPrefix (fst x)))
[ lit (BooleanLit (not (forProxy mInfo))) ]
| otherwise -> varName (prefix unmarshallRefPrefix (fst x))
where
r_ip = varName (prefix unmarshallRefPrefix (mkQVarName mod nm))
{-
Pointer Unique isExp ty
| forRef mInfo &&
optCom &&
isIfaceTy ty -> funApp r_unique [ funApp u_iptr [ final_arg ]]
-}
Pointer pt _ (Name _ _ _ _ _ (Just ti))
| pt /= Ptr && is_pointed ti ->
case pt of
Unique -> funApp readMaybe [ e ]
_ -> e
where
e
| finalised ti = funApply (varName (ref_unmarshaller ti)) [ final_arg ]
| otherwise = varName (ref_unmarshaller ti)
Pointer Ref _ t1@(Name _ _ _ _ (Just ty) _)
| isConstructedTy (nukeNames ty) ->
if isFinalisedType False ty then
funApply r_ty [ final_arg ]
else
r_ty
where
r_ty = varName (mkMarshaller unmarshallRefPrefix t1)
Pointer Ptr _ (Name _ _ _ (Just as) _ _)
| as `hasAttributeWithName` "foreign" -> varName r_fptr
Pointer _ _ Void -> varName r_ptr
Pointer pt _ ty
| isIfaceTy t -> refUnmarshallType mInfo (Pointer Ref True (getIfaceTy t))
| otherwise ->
case pt of
Ptr -> varName r_ptr -- we stop unmarshalling once we encounter a [ptr] pointer.
Ref ->
-- I don't understand the motivation for ignoring the [ref] here any longer!
-- Conseq, -fopt-no-deref-refs can be used to turn off this 'feature' until
-- the ramifications of doing it one way vs. the other can be more carefully
-- assessed (same option applies to ref-marshalling of [ref]s.)
if (forRef mInfo || not (isPointerTy ty)) && not optNoDerefRefs then
refUnmarshallType mInfo ty
else
funApp r_ref [ refUnmarshallType mInfo{forRef=False} ty ]
Unique -> funApp r_unique [ refUnmarshallType mInfo{forRef=False} ty ]
Void -> varName r_addr
Bool -> varName r_bool
CUnion i _ _ ->
let
nm = mkMarshaller unmarshallRefPrefix t
sw =
case (getSwitchIsAttribute (idAttributes i)) of
Just e | notNull fs ->
let v = head fs in var ("read_tag_" ++ v)
where
fs = findFreeVars e
_ -> var ("where_do_I_get_the_tag_from")
in
funApply (varName nm) [sw]
Iface{} -> refUnmarshallType mInfo (Pointer Ref True t)
Name _ _ _ _ _ (Just ti) {- not (is_pointed ti) -} ->
if finalised ti then
funApply (varName (ref_unmarshaller ti)) [ final_arg ]
else
varName (ref_unmarshaller ti)
Name _ _ _ _ (Just ty@Enum{}) _ -> refUnmarshallType mInfo ty
Name _ _ _ _ (Just ty@(Name{})) _ -> refUnmarshallType mInfo ty
Enum{} -> varName r_enum32
Integer LongLong isSigned
| optLongLongIsInteger -> varName (r_integer isSigned)
Name nm _ mod mb_attrs (Just ty) _
| not (forRef mInfo) && isNonEncUnionTy (removeNames ty) ->
funApply (varName (mkMarshaller unmarshallRefPrefix t))
r_args
| not is_cons_type -> refUnmarshallType mInfo ty
| is_cons_type ->
if isFinalisedType False ty then
funApply r_ty [ final_arg ]
else
r_ty
where
r_ty = varName (prefix unmarshallRefPrefix (mkQVarName mod nm))
is_cons_type = isConstructedTy (nukeNames ty)
attrs =
fromMaybe [] mb_attrs ++
idAttributes (getTyTag (getNonEncUnionTy ty))
r_args
| isFinalisedType False ty = [ final_arg, read_tag ]
| otherwise = [ read_tag ]
read_tag =
case getSwitchIsAttribute attrs of
Nothing -> ret (lit (iLit ((-1)::Int)))
Just v -> ret (coreToHaskellExpr v)
_ -> varName (mkMarshaller unmarshallRefPrefix t)
where
r_bool = libImport bool
r_string = libImport stringName
r_blist = libImport blist
r_bstring = libImport bstring
r_ptr = libImport ptrName
r_fptr = libImport fptr
r_ref = libImport ref
r_unique = libImport unique
r_addr = libImport ptrName
r_sequence = libImport "Sequence"
r_safearray
| forStruct mInfo = funApply (varName (prefix unmarshallRefPrefix sAFEARRAY)) [ lit (BooleanLit False) ]
| otherwise = funApply (varName (prefix unmarshallRefPrefix (mkQVarName autoLib safearray)))
[ lit (BooleanLit (not (forProxy mInfo))) ]
r_integer isSigned
| isSigned = libImport integer
| otherwise = libImport ('U':integer)
r_enum32 = libImport enum32
r_iptr = prefix unmarshallRefPrefix iUnknown
final_arg
| forStruct mInfo = var "finaliseMe__"
| otherwise = lit (BooleanLit (forProxy mInfo))
u_iptr = prefix unmarshallPrefix iUnknown
r_wstring
| optNoWideStrings = wStringImport wstring
| otherwise = wStringImport wstring
libImport nm = prefix unmarshallRefPrefix (mkQVarName hdirectLib nm)
wStringImport nm = prefix unmarshallRefPrefix (mkQVarName wStringLib nm)
\end{code}
\begin{code}
coreToHaskellExpr :: Expr -> Haskell.Expr
coreToHaskellExpr e =
case e of
Binary bop e1 e2 -> binOp bop (coreToHaskellExpr e1)
(coreToHaskellExpr e2)
Cond e1 e2 e3 ->
hCase (coreToHaskellExpr e1)
[ alt (conPat (mkQConName prelude "True") []) (coreToHaskellExpr e2)
, alt (conPat (mkQConName prelude "False") []) (coreToHaskellExpr e3)
]
Unary uop e1 -> unaryOp uop (coreToHaskellExpr e1)
Var nm -> var (mkHaskellVarName nm)
Lit l -> lit l
Cast _ e1 -> coreToHaskellExpr e1
-- Sizeof t -> funApp (mkQualName Nothing sizeOfName) [szType t]
Sizeof t -> varName (mkMarshaller sizeofPrefix t)
\end{code}
The library functions does not rely on overloading
of their numeric arguments. Instead, the generated code
will insert coercions that map arguments to the expected
types.
\begin{code}
coerceTy :: Type -> Type -> Haskell.Expr -> Haskell.Expr
coerceTy from_ty to_ty e
| to_ty == from_ty = e
| otherwise = Haskell.WithTy
(funApp (mkQualName prelude (mkHaskellVarName "fromIntegral"))
[ e ])
(toHaskellBaseTy False to_ty)
\end{code}
Allocation and a couple of other functions in the support library
uses Ints as arguments; make sure that arguments passed to them
are properly coerced.
\begin{code}
coerceToInt :: Expr -> Haskell.Expr
coerceToInt e =
case e of
Lit IntegerLit{} -> c_expr
_ -> funApp fromIntegralName [c_expr]
where
c_expr = coreToHaskellExpr e
\end{code}
\begin{code}
szType :: Type -> Haskell.Expr
szType (Array t [e]) = binOp Mul (szType t) (coerceToInt e)
szType t
| isEnum = varName enumSize
| isIntegerTy t = varName (prefix sizeofPrefix (mkQualName hdirectLib "Int64"))
| otherwise =
case t of
Name _ _ _ _ _ (Just ti) -> varName (prim_size ti)
_ -> varName (mkMarshaller sizeofPrefix t)
-- _ -> varName (mkMarshaller sizeOfName t)
where
isEnum = isJust enumRes
enumRes = checkIfEnum t
(Just enumSize) = enumRes
checkIfEnum Enum{} = Just (mkQVarName hdirectLib "sizeofInt32")
checkIfEnum (Name _ _ _ _ (Just ty) _) = checkIfEnum ty
checkIfEnum _ = Nothing
\end{code}
\begin{code}
allocPointerTo :: Type -> Haskell.Expr
allocPointerTo ty =
case ty of
Name _ _ _ _ _ (Just ti) | isJust (alloc_type ti) -> varName (fromJust (alloc_type ti))
Pointer _ _ (Name _ _ _ _ _ (Just ti)) | isJust (alloc_type ti) -> varName (fromJust (alloc_type ti))
_ -> funApp allocBytes [funApp fromIntegralName [szType ty']]
where
ty' =
case ty of
Void -> Pointer Ptr True Void
Pointer _ _ Void -> ty
_ -> removePtr ty
\end{code}
Generating a *call* to free a marshalled representation
of type t (if needed.) The modules that deal with the generation
of marshalling code for user-defined types take care of generating
freeing/release functions for such types.
\begin{code}
freeType :: Type -> Haskell.Expr
freeType ty =
case mbFreeType ty of
Nothing -> varName trivialFree
Just e -> e
mbFreeType :: Type -> Maybe Haskell.Expr
mbFreeType ty =
case ty of
{- Pointer to structs decorated with [free(foo)] are freed using 'foo'. -}
Pointer _ _ (Name _ _ _ _ (Just (Struct tg _ _)) _)
| (idAttributes tg) `hasAttributeWithName` "free" ->
case findAttribute "free" attrs of
Just (Attribute _ [ParamLit (StringLit freeR)]) -> Just (var freeR)
_ -> mbFreeType' True ty
| attrs `hasAttributeWithName` "free_method" ->
-- what an ad-hac hock!
case findAttribute "free_method" attrs of
Just (Attribute _ [ParamLit (StringLit freeR)]) ->
Just (lam [varPat (var "x")] $
funApply (var freeR) [var "x", var "iptr"])
_ -> mbFreeType' True ty
where
attrs = idAttributes tg
_ -> mbFreeType' True ty
mbFreeType' :: Bool -> Type -> Maybe Haskell.Expr
mbFreeType' isTop ty =
case ty of
Pointer _ _ (Name _ _ _ _ _ (Just ti)) | is_pointed ti &&
finalised ti -> Nothing
Pointer _ _ Void -> Nothing
Pointer _ _ Iface{} -> Nothing
{- The Haskell representation of a unique pointer is as a
Maybe-valued `thing', where the `thing' is the unmarshalled
representation of the pointer type. Clearly, the thing we're
pointing to will have to be freed, but it in turn may have
to free up some of its components first.
-}
Pointer Unique _ t
| isIfaceTy t -> Nothing
| otherwise ->
case mbFreeType' False t of
Just v -> Just (funApp (prefix freePrefix (mkQVarName hdirectLib unique)) [ v ])
Nothing | isTop -> Just (varName free)
| otherwise -> Nothing
-- no marshalling was done on this in the first place, so nothing to free.
Pointer Ptr _ _ -> Nothing
-- the type embedded within the reference may have to be freed ...
Pointer Ref _ t ->
case (mbFreeType' False t) of
Just v -> Just (funApp (prefix freePrefix (mkQVarName hdirectLib ref)) [v])
Nothing | isTop -> Just (varName free) -- just free the toplevel pointer.
| otherwise -> Nothing
-- the array may consist of elements that may need to be freed
-- individually, so we better check by looking at the element type..
-- [in many cases element-wise freeing isn't right, since the
-- array was block allocated initially, so let's not do this for
-- now -- assume block allocation.]
Array aty _
| needsFreeing aty -> Just (varName free)
| isTop -> Just (varName free)
| otherwise -> Nothing
-- the String/sequence type contains a null-terminated sequence of unpointed objects,
-- so no need to do per-elt release/free.
String{} -> Just (varName (prefix freePrefix (mkQVarName hdirectLib stringName)))
WString{} -> Just (varName (prefix freePrefix (mkQVarName wStringLib wstring)))
Sequence{} -> Just (varName (prefix freePrefix (mkQVarName hdirectLib "Sequence")))
-- nothing to free for marshalled enums (not in an external heap, anyway.)
Enum{} -> Nothing
-- Note: a toplevel struct is currently not possible, so we don't
-- actually free the structure itself, but assume that whoever has a pointer to
-- this struct value does.
--
-- Notice that since we have complete information about what the struct
-- contains, we could have generated the calls to free up the fields
-- that needs to be explicitly release here. However, the cost of doing
-- this inline hardly seems worth it. (Rely on the Haskell compiler
-- to do the inlining instead.)
--
Struct tg fields _
| any (needsFreeing.fieldType) fields -> Just (varName (prefix freePrefix (mkVarName (idName tg))))
| otherwise -> Nothing
-- See above comment for structs.
-- The tag type isn't pointed (I hope!), so we only need to worry about
-- freeing the embedded value.
Union i _ _ _ switches
| swNeedsFreeing switches -> Just (varName (prefix freePrefix (mkVarName (idName i))))
| otherwise -> Nothing
UnionNon i switches
| swNeedsFreeing switches -> Just (varName (prefix freePrefix (mkVarName (idName i))))
| otherwise -> Nothing
CUnion i fields _
| any (needsFreeing.fieldType) fields -> Just (varName (prefix freePrefix (mkVarName (idName i))))
| otherwise -> Nothing
Name nm _ mod mb_attrs mb_ty mb_ti
| don'tFree mb_attrs ||
(isJust mb_ti &&
finalised (fromJust mb_ti)) -> Nothing
| isJust mb_ti && isJust (free_type (fromJust mb_ti)) -> fmap varName (free_type (fromJust mb_ti))
| otherwise ->
case mb_ty of
Nothing -> Nothing -- Hmm..
Just t
-- want the name of the constructed type rather than its tag...if it needs to be released.
| isConstructedTy (nukeNames t) ->
case mbFreeType' False t of
Just _ | isTop -> Just (funApply (varName (prefix freePrefix (mkQConName mod (mkHaskellTyConName nm))))
args)
_ -> Nothing
| otherwise ->
case mbFreeType' False t of
Just aty | not (don'tFree mb_attrs) -> Just aty
| otherwise -> Nothing
Nothing -> Nothing
where
args
| isNonEncUnionTy t = [read_tag]
| otherwise = []
attrs = fromMaybe [] mb_attrs
read_tag =
case getSwitchIsAttribute attrs of
Nothing -> lit (iLit ((-1)::Int))
Just v -> coreToHaskellExpr v
_ -> Nothing
where
don'tFree Nothing = False
don'tFree (Just ls) = ls `hasAttributeWithName` "nofree"
-- poorly named, but `needsFreeing' returns True
-- if a marshalled representation of an IDL type
-- has to be explicitly released (=> it was allocated
-- externally.)
needsFreeing :: Type -> Bool
needsFreeing t = go True t
where
go toplevel ty =
case ty of
Pointer _ _ (Name _ _ _ _ _ (Just ti)) | is_pointed ti -> not (finalised ti)
Pointer Unique _ pty -> needsFreeing pty
Pointer Ref _ pty -> needsFreeing pty
Pointer Ptr _ _ -> False
Array _ _ -> True
String{} -> toplevel
WString{} -> toplevel
Name _ _ _ _ _ (Just ti) -> not (finalised ti)
Name _ _ _ _ mb_ty _ -> mapFromMb False needsFreeing mb_ty
Struct _ fields _ -> any ((go False).fieldType) fields
Union _ _ _ _ switches -> any sw_go switches
UnionNon _ switches -> any sw_go switches
CUnion _ fields _ -> any ((go False).fieldType) fields
_ -> False -- basic numeric/char types + void & enum.
sw_go (SwitchEmpty _) = False
sw_go s = go False (switchType s)
swNeedsFreeing :: [Switch] -> Bool
swNeedsFreeing [] = False
swNeedsFreeing (SwitchEmpty _ : xs) = swNeedsFreeing xs
swNeedsFreeing (s : xs) = (needsFreeing (switchType s)) || swNeedsFreeing xs
\end{code}