hdirect-0.21.0: src/MarshallDep.lhs
%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Feb. 9th 2003 15:04 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
Handling the marshalling of dependent arguments/fields.
\begin{code}
module MarshallDep
( marshallDependents
, unmarshallDependents
, freeDependent
) where
import qualified AbstractH as Haskell (Expr)
import AbsHUtils
import CoreIDL
import CoreUtils
import MarshallMonad
import MarshallUtils
import MarshallType
import MarshallCore
import BasicTypes
import LibUtils
import List ( nubBy )
import Maybe ( mapMaybe, fromMaybe, fromJust, isJust )
import Monad ( when )
\end{code}
%*
%
\section[marshall-dep]{Marshalling dependent parameters}
%
%*
\begin{code}
marshallDependents :: Bool
-> Bool
-> DependInfo
-> (Name -> Type)
-> Mm ()
marshallDependents inStruct forServer ls lookup_ty = do
sequence (map marshallDep ls)
return ()
where
{-
Marshall the field members/parameters. A field/param
is either a depender or a dependee (never both.)
-}
marshallDep (_, []) = return () -- no dependencies - no code to generate here.
marshallDep (i, deps) = marshallDependent inStruct forServer i lookup_ty deps
\end{code}
This function assumes that the dependencies are correct, that is,
well formed, no duplicates nor conflicting attributes were used
when the dependency information was computed.
foo([in]int *len, [in,size_is(*len)]char* ls);
It performs the following tasks:
- creates let bindings for the dependees, i.e.,
let len = length ls
- marshalls the dependers, i.e.,
ls <- m_list s_Char len w_Char ls
- in preparation for calling the external function,
allocate the dependees, i.e.,
len <- m_ref (allocOutPointer sizeofInt32) w_Int32 len
\begin{code}
marshallDependent :: Bool
-> Bool
-> Id
-> (Name -> Type)
-> [Dependent]
-> Mm ()
marshallDependent _ _ _ _ [Dep SwitchIs [DepVal{}]] = return ()
marshallDependent inStruct forServer i lookup_ty deps' = do
addCode (hLets dep_binds)
(if inStruct && isArrayTy (removeNames ty) then
return ()
else
addCode (bind (funApply marshall_list [real_nm]) real_nm))
when (not forServer) (dep_ptrs >> return ())
return ()
where
nm = idName i
ty = lookup_ty nm
marshall_list = marshallList inStruct
True
ty lookup_ty
(varName m_list)
trans_start_posns
trans_end_posns
alloc_sizes
(trans_start_posns, trans_end_posns, alloc_sizes)
= computeArrayConstraints False{-marshalling-} deps
-- size information may be in part be specified as part of
-- the (array) type, i.e., [size_is(len,)] char arr[][20];
--
-- we push this info into the dependency list here. It really
-- should be done as part of desugaring. (ToDo.)
deps =
case ty of
Array _ es ->
case es of
[] -> deps'
[e] ->
case break (isSizeIs) deps' of
(_,[]) -> ((Dep SizeIs [exprToDep e]):deps')
(as,(Dep SizeIs ds):bs) -> as++(Dep SizeIs (combine ds (exprToDep e))):bs
_ -> error "MarshallDep.marshallDependent: expected a SizeIs attribute"
[e1,e2] -> [ Dep FirstIs [exprToDep e1]
, Dep LastIs [exprToDep e2]
] ++ deps'
_ -> error "MarshallDep.marshallDependent: expected at most two attributes"
where
combine (DepNone:ds) d = d:ds
combine d _ = d
exprToDep e =
case (findFreeVars e) of
[] -> DepVal Nothing e
(v:_) -> DepVal (Just v) e
_ -> deps'
size_deps = filter (\d -> sizeOrLength d &&
hasNonConstantExprs d) deps
dep_binds = nubBy (\ a b -> isVarsEq (fst a) (fst b)) $
concat $
map toBinder size_deps
dep_ptrs = sequence (
map allocPtr $
nubBy (\ (DepVal (Just a) _)
(DepVal (Just b) _) -> a == b) $
filter isDeref $
concat $
map (\ (Dep _ ls) -> ls) size_deps)
real_nm = mkHVar i
-- partial solution
allocPtr (DepVal (Just v) (Unary Deref e)) =
addCode (bind (funApply (marshallType stubMarshallInfo (lookup_ty v))
[coreToHaskellExpr e]) (var v))
allocPtr _ = error "MarshallDep.marshallDependent.allocPtr: unexpected value"
isDeref (DepVal (Just _) (Unary Deref _)) = True
isDeref _ = False
-- convert a dependency list
toBinder (Dep _ ls) = mapMaybe toBinds ls
where
toBinds (DepVal (Just v) e@(Var _)) =
Just ( var v, subst v len (coreToHaskellExpr e))
where
len = mkLength (lookup_ty v)
toBinds (DepVal (Just v) e) =
Just (var v, subst v' len (coreToHaskellExpr (solve v (Var v') e)))
where
v' = v ++ "'"
len = mkLength (lookup_ty v)
toBinds _ = Nothing
mkLength to_ty =
-- if the external function expects a [unique] pointer to the
-- value holding the length, wrap a Just around the length of the list.
case to_ty of
Pointer Unique _ _ -> just length_expr
_ -> length_expr
where
length_expr =
coerceTy intTy (removePtrs to_ty) $
case removeNames ty of
-- if the depender is a wide string, use appropriate
-- length function.
-- ToDo: add a "Type -> QualName" function which
-- returns the name of the length computing function
-- to use for the given Core type.
WString{} -> funApp lengthWString [var nm]
_ -> funApp lengthName [var nm]
\end{code}
\begin{code}
unmarshallDependents :: Bool -- working inside a struct/union?
-> Bool -- dealing with [out] parameters?
-> DependInfo
-> (Name -> Type)
-> Mm ()
unmarshallDependents inStruct is_out ls lookup_ty = do
marshall_dependees
sequence (map unmarshallDep ls)
return ()
where
deps = concat (map snd ls)
{-
Marshal the field members/parameters. A field/param
is either a depender or a dependee (never both.)
-}
unmarshallDep (_, []) = return () -- no dependencies on this one, just continue.
unmarshallDep (i, deps1) =
case (findPtrType True (idAttributes i)) Void of
Pointer Ptr _ _ -> return ()
_ -> unmarshallDependent inStruct is_out i lookup_ty deps1
-- split off into separate function for clarity.
marshall_dependees = sequence (map toBinds code)
code = nubBy theSame $
concatMap (\ (Dep _ ds) -> filter nonConstantDep ds) $
filter (\d -> sizeOrLength d &&
hasNonConstantExprs d &&
not (isResult d)) deps
-- HACK, need to take into account scoping, so that we don't
-- run the risk of not unmarshalling dependent arguments named
-- "result"!
isResult (Dep _ xs) = any isRes xs
where
isRes (DepVal (Just "result") _) = True
isRes _ = False
-- the actions we're creating here are only responsible for fishing
-- out values from pointers, so we only need to do this once.
theSame (DepVal (Just a) _) (DepVal (Just b) _) = a == b
theSame _ _ = False
nonConstantDep (DepVal (Just _) _) = True
nonConstantDep _ = False
toBinds (DepVal (Just v) (Var _))
= let v' = v
ty = lookup_ty v'
in
addCode (bind (funApply (unmarshallType stubMarshallInfo ty) [var v']) (var v'))
toBinds (DepVal (Just v) e) =
let
v' = v ++ "'"
ty = lookup_ty v
{-
For a case like the following:
void foo([out]int *len,[out,size_is(*len+2)]char* ps[]);
we want to generate unmarshalling code for ps that gets at the
value of len:
len <- ((u_ref r_Int32) len)
let len' = (len + 2)
ps <- u_list s_Addr 0 (fromIntegral len') ....
the code below generates the first two lines, binding the value
read out of
-}
in do
addCode (bind (funApply (unmarshallType stubMarshallInfo ty) [var v]) (var v))
addToEnv v v'
addCode (hLet (var v') (subst v (var v) (coreToHaskellExpr e)))
toBinds _ = error "MarshallDep.unmarshallDependents.toBinds: unexpected value"
{-
This function assumes that the dependencies are correct, that is,
well formed, no duplicate nor conflicting attributes were used
when the dependency information was computed.
-}
unmarshallDependent :: Bool
-> Bool
-> Id
-> (Name -> Type)
-> [Dependent]
-> Mm ()
unmarshallDependent _ _ _ _ [Dep SwitchIs _] = return ()
unmarshallDependent inStruct is_out i lookup_ty deps' = do
unmarsh <- unmarshallList inStruct
True{-at top-level-}
ty
lookup_ty
(trans_start_posns)
(trans_end_posns)
(alloc_sizes)
let
-- in the case of [out] parameters, de-reference the
-- the pointer to get at the goods. This is only done
-- when the [out] parameter was (at least) a pointer to
-- a pointer to something. If not, then the [out] pointer
-- points to the piece of a memory (we've already allocated)
-- and are now ready to unmarshal.
unmarsh'
| is_out && allocated_space_for = funApp r_ref [unmarsh]
| otherwise = unmarsh
unmarsh_and_free
| is_out =
funApp doThenFree
[ fromMaybe (varName trivialFree) (freeDependentE i lookup_ty deps')
, unmarsh'
]
| otherwise = unmarsh'
addCode (bind (funApply unmarsh_and_free [nm_var]) nm_var)
where
nm = idName i
tentative_ty = lookup_ty nm
ty
| should_peel = removePtr tentative_ty
| otherwise = tentative_ty
nm_var = mkHVar i
{-
Determine whether we had to allocate space for an [out] pointer.
If we did, we need to deref this pointer before unmarshalling -- see above.
-}
allocated_space_for =
is_out &&
let
(_, _, cs1) = computeArrayConstraints False{-marshalling-} deps'
in
case cs1 of
(DepNone:_) -> True
_ -> False
should_peel
| not is_out = False
| otherwise =
case cs of
(DepNone:_) -> True
_ -> False
{-
-- size information may be in part be specified as part of
-- the (array) type, i.e., [size_is(len,)] char arr[][20];
--
-- we push this info into the dependency list here. It really
-- should be done as part of desugaring. (ToDo.)
deps =
case ty of
Array _ es ->
case es of
[] -> deps'
[e] ->
case break (isSizeIs) deps' of
(as,[]) -> ((Dep SizeIs [exprToDep e]):deps')
(as,(Dep SizeIs ds):bs) -> as++(Dep SizeIs (combine ds (exprToDep e))):bs
[e1,e2] -> [ Dep FirstIs [exprToDep e1]
, Dep LastIs [exprToDep e2]
] ++ deps'
where
combine (DepNone:ds) d = d:ds
combine d _ = d
exprToDep e =
case (findFreeVars e) of
[] -> DepVal Nothing e
(v:_) -> DepVal (Just v) e
_ -> deps'
-}
(as, bs, cs) = computeArrayConstraints True{-unmarshalling-} deps'
(trans_start_posns, trans_end_posns, alloc_sizes)
| should_peel = (tail as, tail bs, tail cs) -- peel off the toplevel pointer for [out] params
| otherwise = (as, bs, cs)
\end{code}
\begin{code}
marshallList :: Bool
-> Bool
-> Type
-> (Name -> Type)
-> Haskell.Expr
-> [DepVal]{-start index of transmits, one for each dim.-}
-> [DepVal]{-end index of transmits-}
-> [DepVal]{-size to allocate (for each dimension)-}
-> Haskell.Expr
marshallList inStruct topLev ty _ _ [] [] [] = marshallElts inStruct topLev True ty
marshallList inStruct topLev ty lookup_ty marshaller
(_:starts) (_:ends) (_:sz_allocs)
| (isPointerTy r_ty && not (isVoidPointerTy r_ty)) || isArrayTy r_ty =
funApply marshaller
[ szType ty'
, marshallList inStruct False ty' lookup_ty ref_marshaller starts ends sz_allocs
]
| otherwise = marshallElts inStruct topLev True ty
where
r_ty = removeNames ty
ref_marshaller = funApp w_list [varName alloc_list]
alloc_list
| isStringTy ty' ||
isPointerTy ty' ||
isArrayTy ty' = true
| otherwise = false
ty' = removePtrAndArray r_ty
marshallList _ _ _ _ _ _ _ _ = error "MarshallDep.marshallList: the impossible happened"
unmarshallList :: Bool
-> Bool
-> Type
-> (Name -> Type)
-> [DepVal]{-start index of transmits, one for each dim.-}
-> [DepVal]{-end index of transmits-}
-> [DepVal]{-size to allocate (for each dimension)-}
-> Mm Haskell.Expr
unmarshallList inStruct topLev ty _ [] [] [] = return (marshallElts inStruct topLev False ty)
unmarshallList inStruct topLev ty l_ty
(_:starts) (_:ends) (sz:sz_allocs)
| (isPointerTy r_ty && not (isVoidPointerTy r_ty)) ||
isArrayTy r_ty = do
rest <- unmarshallList inStruct False ty' l_ty starts ends sz_allocs
len <- mkLengthExpr sz l_ty
return (funApp u_list [ szType ty'
, var "0"
, len
, rest
])
| otherwise = return (marshallElts inStruct topLev False ty)
where
r_ty = removeNames ty
ty' = removePtrAndArray r_ty
unmarshallList _ _ _ _ _ _ _ = error "MarshallDep.unmarshallList: the impossible happened"
mkLengthExpr :: DepVal -> (Name -> Type) -> Mm Haskell.Expr
mkLengthExpr sz lookup_ty =
case sz of
DepNone -> return nothing
DepVal Nothing e -> return (coerceTy intTy word32Ty (coreToHaskellExpr e))
DepVal (Just v) e -> do
mb_nm <- lookupName v
mNm <- getMethodName
let
nm =
case mb_nm of
Nothing
| v == "result" && isJust mNm ->
outPrefix ++ fromJust mNm
| otherwise ->
error ("MarshallDep.mkLengthExpr: unbound variable ('" ++
nm ++ "') encountered in length_is() attribute")
Just x -> x
ty = lookup_ty v
h_e = subst v (var nm) (coreToHaskellExpr e)
coerce = coerceTy (removePtrs ty) word32Ty
{-
In the case the length is given via a [unique] pointer,
we will have at this stage unmarshalled it to a Maybe value.
Convert the Maybe value into a length here.
-}
case ty of
Pointer Unique _ _ -> return (
funApp fromMaybeName
[ var "0"
, funApp mapName [lam [patVar "x"]
(coerce (var "x")), h_e]
])
Pointer Ptr _ _ -> error "mkLengthExpr: Ptr - no can do."
_ -> return (coerce h_e)
marshallElts :: Bool -> Bool -> Bool -> Type -> Haskell.Expr
marshallElts inStruct topLev marshalling ty
| marshalling && topLev = marshallType mInfo ty
| marshalling = refMarshallType mInfo ty
| topLev = unmarshallType mInfo ty
| otherwise = refUnmarshallType mInfo ty
where
mInfo = stubMarshallInfo{forStruct=inStruct,forRef=True}
\end{code}
When freeing up values that have been classified and marshalled as
dependent [in] params, we need to make sure we free the entire structure
that has been previously allocated. @freeDependent@ takes care of this,
by, in effect, by reconstructing what kind of pointer / array value that
the 'dependent arg' marshaller previously constructed.
\begin{code}
freeDependent :: Id -> (Name -> Type) -> [Dependent] -> Mm ()
freeDependent i lookup_ty deps =
case freeDependentE i lookup_ty deps of
Nothing -> return ()
Just f -> addCode (bind_ (funApply f [real_nm]))
where
real_nm = mkHVar i
freeDependentE :: Id -> (Name -> Type) -> [Dependent] -> Maybe Haskell.Expr
freeDependentE i lookup_ty deps = free_list
where
free_list = freeList ty lookup_ty trans_start_posns trans_end_posns alloc_sizes
(trans_start_posns, trans_end_posns, alloc_sizes)
= computeArrayConstraints False{-not unmarshaling-} deps
ty = lookup_ty (idName i)
freeList :: Type
-> (Name -> Type)
-> [DepVal]{-start index of transmits, one for each dim.-}
-> [DepVal]{-end index of transmits-}
-> [DepVal]{-size to allocate (for each dimension)-}
-> Maybe Haskell.Expr
freeList ty _ [] [] [] = freeElts (removePtrAndArray ty)
freeList ty _ (_:_) (_:_) (_:_)
| (isPointerTy ty || isArrayTy ty) && needsFreeing ty' =
Just $ (varName free)
{-
funApp f_list
[ szType ty'
, length_of sz
, fromMaybe (varName trivialFree) (freeList ty' lookup_ty starts ends sz_allocs)
]
-}
| otherwise = freeElts ty
where
ty' = removePtrAndArray ty
{-
length_of (DepVal Nothing e) = coreToHaskellExpr e
length_of (DepVal (Just v) e) =
coerceTy (removePtrs (lookup_ty v)) word32Ty (coreToHaskellExpr e)
-}
freeList _ _ _ _ _ = error "MarshallDep.freeList: the impossible happened"
freeElts :: Type -> Maybe Haskell.Expr
freeElts ty =
case ty of
Sequence{} -> Just $ varName free
--Just $ funApp f_list [ szType t, freeElts' t ] -- wrong.
Fixed{} -> error "not implemented yet."
SafeArray t -> Just $ funApp f_list [ szType t, freeElts' t]
Array Void (d:_) -> Just $ funApp f_list [ szType (Pointer Ptr True Void)
, coreToHaskellExpr d
, mkEltFreer (Pointer Ptr True Void)
]
Array t (d:_) -> Just $ funApp f_list [ szType t, coreToHaskellExpr d, freeElts' t]
String{} -> Just $ varName f_string
WString{} -> Just $ varName f_wstring
Pointer _ _ Iface{} -> Nothing
Pointer _ _ Void -> Just $ varName free
Pointer Ref _ (Char _) -> Just $ varName f_string
Pointer pt _ pty
| pt == Ref -> Just $ funApp f_ref [ freeElts' pty ]
| pt == Unique -> Just $ funApp f_unique [ freeElts' pty ]
| otherwise -> Just $ varName f_ptr
_ | needsFreeing ty -> Just (mkEltFreer ty)
| otherwise -> Nothing
where
freeElts' t = fromMaybe (varName trivialFree) (freeElts t)
mkEltFreer ety = varName (mkMarshaller freePrefix ety)
\end{code}
Constants referring to library marshallers:
\begin{code}
m_list, w_list, u_list, f_list :: QualName
m_list = prefix marshallPrefix (mkQVarName hdirectLib list)
w_list = prefix marshallRefPrefix (mkQVarName hdirectLib list)
u_list = prefix unmarshallPrefix (mkQVarName hdirectLib list)
f_list = prefix freePrefix (mkQVarName hdirectLib list)
{-
r_list :: QualName
r_list = prefix unmarshallRefPrefix (mkQVarName hdirectLib list)
-}
f_string :: QualName
f_string = prefix freePrefix (mkQVarName hdirectLib stringName)
f_unique, r_ref, f_ref, f_wstring :: QualName
f_unique = prefix freePrefix (mkQVarName hdirectLib unique)
r_ref = prefix unmarshallRefPrefix (mkQVarName hdirectLib ref)
f_ref = prefix freePrefix (mkQVarName hdirectLib ref)
f_wstring = prefix freePrefix (mkQVarName comLib wstring)
f_ptr :: QualName
f_ptr = free
\end{code}