%if false
Flounder2: an even more simpler IDL for Barrelfish
-
+
Copyright (c) 2009 ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
> preamble :: Interface -> String -> String
> preamble interface filename =
-> let name =
+> let name =
> case interface of
> Interface _ (Just desc) _ -> desc
> _ -> ""
> qualifyName :: String -> TypeRef -> String
> qualifyName interfaceName (Builtin t) = show t
-> qualifyName interfaceName (TypeVar t) = interfaceName ++ "_" ++ t
+> qualifyName interfaceName (TypeVar t) = interfaceName ++ "_" ++ t
> qualifyName interfaceName (TypeAlias t _) = interfaceName ++ "_" ++ t
When we are declarating real C types, we have to add a @_t@ at the
@_fn@ specifier.
> qualifyProcName :: String -> TypeRef -> String
-> qualifyProcName interfaceName typeDef =
+> qualifyProcName interfaceName typeDef =
> qualifyName interfaceName typeDef ++ "_fn"
containing the message declarations.
> partitionTypesMessages :: [Declaration] -> ([TypeDef], [MessageDef])
-> partitionTypesMessages declarations =
+> partitionTypesMessages declarations =
> let (types, messages) = foldl' typeFilter ([],[]) declarations in
> (types, reverse messages)
> where typeFilter (types, messages) (Messagedef m) = (types, m : messages)
difference is materialized by the following data-type:
> data Side = ServerSide
-> | ClientSide
+> | ClientSide
> instance Show Side where
> show ServerSide = "service"
To compile the list of arguments of messages, we use:
> compileCommonDefinitionArgs :: String -> Side -> MessageDef -> [(String,String)]
-> compileCommonDefinitionArgs interfaceName side message@(Message _ _ messageArgs _) =
+> compileCommonDefinitionArgs interfaceName side message@(Message _ _ messageArgs _) =
> [("struct " ++ interfaceName ++ "_" ++ show side ++ "_response *", "st")]
> ++ [(constType typeArg ++ " " ++ qualifyType interfaceName typeArg, nameOf arg)
> | Arg typeArg arg <- messageArgs ]
> compileRPCDefinitionArgs :: String -> [RPCArgument] -> [(String,String)]
-> compileRPCDefinitionArgs interfaceName rpcArgs =
+> compileRPCDefinitionArgs interfaceName rpcArgs =
> ("struct " ++ interfaceName ++ "_client_response *", "st" ) :
> [ case messageArg of
> RPCArgIn typeArg arg ->
-> (constType typeArg ++ " "
+> (constType typeArg ++ " "
> ++ qualifyType interfaceName typeArg,
> nameOf arg)
> RPCArgOut typeArg arg ->
{-
BackendCommon: Common code used by most backends
-
+
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module BackendCommon where
-- Name of each element of the message number enumeration
msg_enum_elem_name :: String -> String -> String
-msg_enum_elem_name ifn mn = idscope ifn mn "msgnum"
+msg_enum_elem_name ifn mn = idscope ifn mn "msgnum"
-- Name of the type of a message function
msg_sig_type :: String -> MessageDef -> Direction -> String
intf_vtbl_type ifn TX = ifscope ifn "tx_vtbl"
intf_vtbl_type ifn RX = ifscope ifn "rx_vtbl"
-connect_callback_name n = ifscope n "connect_fn"
+connect_callback_name n = ifscope n "connect_fn"
drv_connect_handler_name drv n = drvscope drv n "connect_handler"
drv_connect_fn_name drv n = drvscope drv n "connect"
drv_accept_fn_name drv n = drvscope drv n "accept"
------------------------------------------------------------------------
intf_preamble :: String -> String -> Maybe String -> C.Unit
-intf_preamble infile name descr =
+intf_preamble infile name descr =
let dstr = case descr of
Nothing -> "not specified"
Just s -> s
in
- C.MultiComment [
+ C.MultiComment [
"Copyright (c) 2010, ETH Zurich.",
"All rights reserved.",
"",
(restin, restout) = partition_rpc_args rest
msg_argdecl :: Direction -> String -> MessageArgument -> [C.Param]
-msg_argdecl dir ifn (Arg tr (Name n)) =
+msg_argdecl dir ifn (Arg tr (Name n)) =
[ C.Param (type_c_type_dir dir ifn tr) n ]
-msg_argdecl RX ifn (Arg tr (DynamicArray n l)) =
- [ C.Param (C.Ptr $ type_c_type_dir RX ifn tr) n,
+msg_argdecl RX ifn (Arg tr (DynamicArray n l)) =
+ [ C.Param (C.Ptr $ type_c_type_dir RX ifn tr) n,
C.Param (type_c_type_dir RX ifn size) l ]
-msg_argdecl TX ifn (Arg tr (DynamicArray n l)) =
- [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir TX ifn tr) n,
+msg_argdecl TX ifn (Arg tr (DynamicArray n l)) =
+ [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir TX ifn tr) n,
C.Param (type_c_type_dir TX ifn size) l ]
msg_argstructdecl :: String -> [TypeDef] -> MessageArgument -> [C.Param]
-msg_argstructdecl ifn typedefs (Arg tr (Name n)) =
+msg_argstructdecl ifn typedefs (Arg tr (Name n)) =
[ C.Param (type_c_type_msgstruct ifn typedefs tr) n ]
msg_argstructdecl ifn typedefs a = msg_argdecl RX ifn a
rpc_argdecl :: String -> RPCArgument -> [C.Param]
rpc_argdecl ifn (RPCArgIn tr v) = msg_argdecl TX ifn (Arg tr v)
rpc_argdecl ifn (RPCArgOut tr (Name n)) = [ C.Param (C.Ptr $ type_c_type ifn tr) n ]
-rpc_argdecl ifn (RPCArgOut tr (DynamicArray n l)) =
- [ C.Param (C.Ptr $ C.Ptr $ type_c_type ifn tr) n,
+rpc_argdecl ifn (RPCArgOut tr (DynamicArray n l)) =
+ [ C.Param (C.Ptr $ C.Ptr $ type_c_type ifn tr) n,
C.Param (C.Ptr $ type_c_type ifn size) l ]
-- XXX: kludge wrapper to pass array types by reference in RPC
-- Generate a generic can_send function
--
can_send_fn_def :: String -> String -> C.Unit
-can_send_fn_def drv ifn =
+can_send_fn_def drv ifn =
C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drv ifn) params [
C.Return $ C.Binary C.Equals (bindvar `C.DerefField` "tx_msgnum") (C.NumConstant 0)
]
-- generate a generic control function that does nothing
--
generic_control_fn_def :: String -> String -> C.Unit
-generic_control_fn_def drv ifn =
+generic_control_fn_def drv ifn =
C.FunctionDef C.Static (C.TypeName "errval_t") (generic_control_fn_name drv ifn) params [
C.SComment "no control flags are supported",
C.Return $ C.Variable "SYS_ERR_OK"
$ C.Call "malloc" [C.SizeOfT $ type_c_type ifn tr],
C.Ex $ C.Call "assert" [C.Binary C.NotEquals (field fn) (C.Variable "NULL")]
] | Arg tr (Name fn) <- msgargs, is_array tr]
-
+
where
field fn = rx_union_elem mn fn
is_array tr = case lookup_typeref typedefs tr of
C.Ex $ C.Assignment (tx_union_elem mn len) (C.Variable len)]
where
typespec = type_c_type ifn tr
- srcarg an =
+ srcarg an =
case lookup_typeref typedefs tr of
-- XXX: I have no idea why GCC requires a cast for the array type
TArray _ _ _ -> C.Cast (C.Ptr typespec) (C.Variable an)
{-
CAbsSyntax: combinators for generating C99 syntax
-
+
Part of Mackerel: a strawman device definition DSL for Barrelfish
-
+
Copyright (c) 2009, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module CAbsSyntax where
tabstop = " " -- How much to indent
-indent_stmts :: [ Stmt ] -> [ String ]
+indent_stmts :: [ Stmt ] -> [ String ]
indent_stmts sl = [ tabstop ++ l | l <- concat [ pp_stmt s | s <- sl ] ]
---
+--
-- We start with expressions
--
data Expr = NumConstant Integer -- 123
pp_expr (DerefField e s) = (pp_par_expr e) ++ "->" ++ s
pp_expr (Assignment e1 e2) = (pp_expr e1) ++ " = " ++ (pp_par_expr e2)
pp_expr (Unary o e) = (pp_unop o) ++ (pp_par_expr e)
-pp_expr (Binary o e1 e2)
+pp_expr (Binary o e1 e2)
= (pp_par_expr e1) ++" " ++ (pp_binop o) ++ " "++(pp_par_expr e2)
-pp_expr (Ternary e1 e2 e3)
+pp_expr (Ternary e1 e2 e3)
= (pp_par_expr e1) ++ " ? " ++ (pp_par_expr e2) ++ " : " ++ (pp_par_expr e3)
pp_expr (FieldOf e s) = (pp_par_expr e) ++ "." ++ s
pp_expr (SubscriptOf e1 e2) = (pp_par_expr e1) ++ "[" ++ (pp_expr e2) ++ "]"
-pp_expr (Call f al)
+pp_expr (Call f al)
= f ++ "(" ++ (concat $ intersperse ", " [ pp_expr e | e <- al ]) ++ ")"
-pp_expr (CallInd f al)
+pp_expr (CallInd f al)
= "(" ++ (pp_expr f) ++ ")(" ++ (concat $ intersperse ", " [ pp_expr e | e <- al ]) ++ ")"
pp_expr (SizeOf e) = "sizeof(" ++ (pp_expr e) ++ ")"
pp_expr (SizeOfT t) = "sizeof(" ++ (pp_typespec t "") ++ ")"
--
-- Binary operators
--
-data BinOp = Plus
- | Minus
- | Times
- | Divide
- | Modulo
+data BinOp = Plus
+ | Minus
+ | Times
+ | Divide
+ | Modulo
| Equals
| NotEquals
| GreaterThan
- | LessThan
+ | LessThan
| GreaterThanEq
| LessThanEq
| BitwiseAnd
| BitwiseOr
| BitwiseXor
| And
- | Or
+ | Or
| LeftShift
| RightShift
deriving (Show, Eq)
--
-- Unary operators
--
-data UnOp = Not | Negate | BitwiseNot
+data UnOp = Not | Negate | BitwiseNot
deriving (Show, Eq)
pp_unop :: UnOp -> String
pp_constspec NonConst = ""
--
--- A Unit is a chunk of source file, i.e. top-level syntactic constructs.
+-- A Unit is a chunk of source file, i.e. top-level syntactic constructs.
--
--- Note that we treat static inlines as their own construct. It's easier.
+-- Note that we treat static inlines as their own construct. It's easier.
--
data Unit = Comment String
| MultiComment [ String ]
| Include IncludePath String
deriving (Show, Eq)
-pp_unit :: Unit -> [ String ]
+pp_unit :: Unit -> [ String ]
pp_unit (Comment s) = [ "// " ++ s ]
-pp_unit (MultiComment sl) = ["/*"] ++ [ " * " ++ s | s <- sl ] ++ [ " */"]
+pp_unit (MultiComment sl) = ["/*"] ++ [ " * " ++ s | s <- sl ] ++ [ " */"]
pp_unit (TypeDef ts s) = [ "typedef " ++ (pp_typespec ts s) ++ ";" ]
pp_unit (FunctionDef sc ts n pl body) =
[ (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl) ] ++ (pp_fnbody body)
-pp_unit (StaticInline ts n pl body) =
+pp_unit (StaticInline ts n pl body) =
[ head ++ " __attribute__ ((always_inline));",
head ] ++ (pp_fnbody body)
- where
+ where
head = "static inline " ++ (pp_fnhead ts n pl)
-pp_unit (StructDecl s pl) =
+pp_unit (StructDecl s pl) =
[ printf "struct %s {" s ] ++ pp_structunion_body pl ++ ["};"]
-pp_unit (StructForwardDecl s) =
+pp_unit (StructForwardDecl s) =
[ printf "struct %s;" s ]
pp_unit (StructDef sc s n fl) =
[ (pp_scopespec sc) ++ " " ++ (printf "struct %s %s = {" s n)]
++ [ tabstop ++ (pp_fieldinit f) | f <- fl ] ++ ["};"]
where
pp_fieldinit (n,v) = printf ".%s = %s," n v
-pp_unit (UnionDecl s pl) =
- [ printf "union %s {" s ] ++ [ tabstop ++ (pp_param p) ++ ";"
+pp_unit (UnionDecl s pl) =
+ [ printf "union %s {" s ] ++ [ tabstop ++ (pp_param p) ++ ";"
| p <- pl ] ++ ["};"]
-pp_unit (UnionForwardDecl s) =
+pp_unit (UnionForwardDecl s) =
[ printf "union %s;" s ]
-pp_unit (EnumDecl s el) =
- [ printf "typedef enum %s {" s ]
- ++
+pp_unit (EnumDecl s el) =
+ [ printf "typedef enum %s {" s ]
+ ++
(comma_sep_lines [ tabstop ++ (pp_enumitem e) | e <- el ])
- ++
+ ++
[ printf "} %s;" s]
--- pp_unit (FunctionDecl sc ts n pl) =
+-- pp_unit (FunctionDecl sc ts n pl) =
-- [ (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl) ++ ";" ]
-pp_unit (GVarDecl sc cs ts s Nothing) =
+pp_unit (GVarDecl sc cs ts s Nothing) =
[ printf "%s%s%s;" (pp_scopespec sc) (pp_constspec cs) (pp_typespec ts s)]
-pp_unit (GVarDecl sc cs ts s (Just e)) =
- [ printf "%s%s%s = %s;"
- (pp_scopespec sc)
- (pp_constspec cs)
- (pp_typespec ts s)
+pp_unit (GVarDecl sc cs ts s (Just e)) =
+ [ printf "%s%s%s = %s;"
+ (pp_scopespec sc)
+ (pp_constspec cs)
+ (pp_typespec ts s)
(pp_expr e) ]
pp_unit (Define n [] v) = [ printf "#define %s %s" n v ]
-pp_unit (Define n al v)
+pp_unit (Define n al v)
= [ printf "#define %s(%s) %s" n (concat $ intersperse "," al) v ]
pp_unit (Undef s) = [ "#undef " ++ s ]
-pp_unit (IfDef s l r) = pp_cppcond "ifdef" s l r
-pp_unit (IfNDef s l r) = pp_cppcond "ifndef" s l r
-pp_unit (HashIf s l r) = pp_cppcond "if" s l r
-pp_unit (UnitList l) = concat $ map pp_unit l
+pp_unit (IfDef s l r) = pp_cppcond "ifdef" s l r
+pp_unit (IfNDef s l r) = pp_cppcond "ifndef" s l r
+pp_unit (HashIf s l r) = pp_cppcond "if" s l r
+pp_unit (UnitList l) = concat $ map pp_unit l
pp_unit NoOp = []
pp_unit Blank = [""]
pp_unit (Include s p) = [ pp_include s p ]
opt_trailer (Param _ _) = ";"
opt_trailer _ = ""
-comma_sep_lines :: [String] -> [String]
+comma_sep_lines :: [String] -> [String]
comma_sep_lines [] = []
comma_sep_lines [s] = [s]
comma_sep_lines (s:sl) = (s ++ ","):(comma_sep_lines sl)
pp_cppcond :: String -> String -> [ Unit ] -> [ Unit ] -> [ String ]
-pp_cppcond t e l r =
- [ "#" ++ t ++ " " ++ e ]
- ++
+pp_cppcond t e l r =
+ [ "#" ++ t ++ " " ++ e ]
+ ++
(concat [ pp_unit u | u <- l ])
- ++
+ ++
(if r == [] then [] else "#else":concat [ pp_unit u | u <- r ])
- ++
+ ++
[ "#endif // " ++ e ]
pp_cppcond_stmt :: String -> String -> [ Stmt ] -> [ Stmt ] -> [ String ]
-pp_cppcond_stmt t e l r =
- [ "#" ++ t ++ " " ++ e ]
- ++
+pp_cppcond_stmt t e l r =
+ [ "#" ++ t ++ " " ++ e ]
+ ++
(concat [ pp_stmt u | u <- l ])
- ++
+ ++
(if r == [] then [] else "#else":concat [ pp_stmt u | u <- r ])
- ++
+ ++
[ "#endif // " ++ e ]
-pp_fnbody :: [ Stmt ] -> [ String ]
+pp_fnbody :: [ Stmt ] -> [ String ]
pp_fnbody body = [ "{" ] ++ (indent_stmts body) ++ [ "}", ""]
pp_fnhead :: TypeSpec -> String -> [ Param ] -> String
-pp_fnhead ts n pl =
- (pp_typespec ts n) ++ "(" ++ parlist ++ ")"
- where
+pp_fnhead ts n pl =
+ (pp_typespec ts n) ++ "(" ++ parlist ++ ")"
+ where
parlist = concat $ intersperse ", " [ pp_param p | p <- pl ]
---
+--
-- Branches of a case statement: note that they fall through
--
data Case = Case Expr [ Stmt ]
deriving (Show, Eq)
-
+
pp_case :: Case -> [ String ]
-pp_case (Case e s)
+pp_case (Case e s)
= [ "case " ++ (pp_expr e) ++ ":" ] ++ (indent_stmts s)
--
-- Statements.
--
-data Stmt = Return Expr
+data Stmt = Return Expr
| ReturnVoid
| Block [ Stmt ]
| StmtList [ Stmt ]
| Ex Expr
| If Expr [ Stmt ] [ Stmt ]
| DoWhile Expr [ Stmt ]
- | While Expr [ Stmt ]
+ | While Expr [ Stmt ]
| For Expr Expr Expr [ Stmt ]
| Switch Expr [ Case ] [ Stmt ] -- last list is default clause
| Break
pp_stmt (Block sl) = [ "{" ] ++ (indent_stmts sl) ++ ["}"]
pp_stmt (StmtList sl) = concat $ map pp_stmt sl
pp_stmt (Ex e) = [ (pp_expr e) ++ ";" ]
-pp_stmt (If e sl []) =
+pp_stmt (If e sl []) =
[ "if (" ++ (pp_expr e) ++ ") {" ] ++ (indent_stmts sl) ++ ["}"]
-pp_stmt (If e sl1 sl2)
- = [ "if (" ++ (pp_expr e) ++ ") {" ]
- ++ (indent_stmts sl1)
- ++ ["} else {"]
+pp_stmt (If e sl1 sl2)
+ = [ "if (" ++ (pp_expr e) ++ ") {" ]
+ ++ (indent_stmts sl1)
+ ++ ["} else {"]
++ (indent_stmts sl2) ++ [ "}"]
-pp_stmt (DoWhile e sl)
+pp_stmt (DoWhile e sl)
= [ "do {" ] ++ (indent_stmts sl) ++ [ "} while (" ++ (pp_expr e) ++ ");" ]
-pp_stmt (While e sl)
- = [ "while (" ++ (pp_expr e) ++ ") {" ]
+pp_stmt (While e sl)
+ = [ "while (" ++ (pp_expr e) ++ ") {" ]
++ (indent_stmts sl) ++ ["}"]
-pp_stmt (For e1 e2 e3 sl)
- = ( [ "for( " ++ (pp_expr e1) ++ "; "
- ++ (pp_expr e2) ++ "; "
- ++ (pp_expr e3) ++ ") {"
+pp_stmt (For e1 e2 e3 sl)
+ = ( [ "for( " ++ (pp_expr e1) ++ "; "
+ ++ (pp_expr e2) ++ "; "
+ ++ (pp_expr e3) ++ ") {"
]
- ++ (indent_stmts sl)
+ ++ (indent_stmts sl)
++ ["}"]
)
-pp_stmt (Switch e cl sl)
- = ( [ "switch (" ++ (pp_expr e) ++ ") {" ]
- ++ concat [ pp_case c | c <- cl ]
- ++ [ "default:" ]
+pp_stmt (Switch e cl sl)
+ = ( [ "switch (" ++ (pp_expr e) ++ ") {" ]
+ ++ concat [ pp_case c | c <- cl ]
+ ++ [ "default:" ]
++ (indent_stmts sl)
++ [ "}" ]
)
pp_stmt Continue = [ "continue;" ]
pp_stmt (Label s) = [ s ++ ":" ]
pp_stmt (Goto s) = [ "goto " ++ s ++ ";" ]
-pp_stmt (VarDecl sc cs ts s Nothing) =
+pp_stmt (VarDecl sc cs ts s Nothing) =
[ printf "%s%s%s;" (pp_scopespec sc) (pp_constspec cs) (pp_typespec ts s)]
-pp_stmt (VarDecl sc cs ts s (Just e)) =
- [ printf "%s%s%s = %s;"
- (pp_scopespec sc)
- (pp_constspec cs)
- (pp_typespec ts s)
+pp_stmt (VarDecl sc cs ts s (Just e)) =
+ [ printf "%s%s%s = %s;"
+ (pp_scopespec sc)
+ (pp_constspec cs)
+ (pp_typespec ts s)
(pp_expr e) ]
pp_stmt (SComment s) = [ "// " ++ s ]
pp_stmt SBlank = [ "" ]
-pp_stmt (SIfDef s l r) = pp_cppcond_stmt "ifdef" s l r
+pp_stmt (SIfDef s l r) = pp_cppcond_stmt "ifdef" s l r
--
-- Type specifiers
data TypeSpec = Void
| Struct String
| Union String
- | Enum String
+ | Enum String
| Ptr TypeSpec
| Array Integer TypeSpec
| TypeName String
pp_typespec (Array 0 t) n = pp_typespec t (n++"[]")
pp_typespec (Array i t) n = pp_typespec t $ printf "%s[%d]" n i
pp_typespec (TypeName s) n = printf "%s %s" s n
-pp_typespec (Function sc ts pl) n
+pp_typespec (Function sc ts pl) n
= (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl)
pp_typespec (ConstT t) n = "const " ++ pp_typespec t n
pp_typespec (Volatile t) n = "volatile " ++ pp_typespec t n
{-
- CSyntax: functions for rendering C syntactic structures.
-
+ CSyntax: functions for rendering C syntactic structures.
+
Part of Mackerel: a strawman device definition DSL for Barrelfish
-
+
Copyright (c) 2007, 2008, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module CSyntax where
reverse ((x ++ " " ++ s):xs )
header_file :: String -> String -> String
-header_file name body =
- let sym = "__" ++ name ++ "_H"
+header_file name body =
+ let sym = "__" ++ name ++ "_H"
in unlines [ "#ifndef " ++ sym,
"#define " ++ sym,
"",
include_local f = "#include \"" ++ f ++ ".h\""
block :: [String] -> [String]
-block lines =
+block lines =
["{"] ++ (indent lines) ++ ["}"]
typedef :: String -> String -> String
-typedef name typestr = "typedef " ++ typestr ++ " " ++ name ++ ";"
+typedef name typestr = "typedef " ++ typestr ++ " " ++ name ++ ";"
constint :: String -> Integer -> String
constint name val = printf "static const int %s = 0x%0x;" name val
struct :: String -> [ String ] -> [ String ]
-struct name fields = structunion "struct" name fields
+struct name fields = structunion "struct" name fields
struct_field n v = printf "%s\t%s;" n v
union_field n v = struct_field n v
structunion :: String -> String -> [ String ] -> [ String ]
-structunion su name fields =
- (su ++ " " ++ name) >: (block fields)
+structunion su name fields =
+ (su ++ " " ++ name) >: (block fields)
-bitfields name fields =
- ("struct " ++ name) >: (block fields) <: "__attribute__ ((packed))"
+bitfields name fields =
+ ("struct " ++ name) >: (block fields) <: "__attribute__ ((packed))"
-bitfield n w t = printf "%s\t%s\t:%d;" t n w
+bitfield n w t = printf "%s\t%s\t:%d;" t n w
enum :: String -> [ (String, String) ] -> String
-enum name vals =
- let tname = name -- ++ "_t"
+enum name vals =
+ let tname = name -- ++ "_t"
in
- unlines ( ((printf "typedef enum %s" tname)
+ unlines ( ((printf "typedef enum %s" tname)
>: block [ printf "%s = %s," n v | (n, v) <- vals] )
<: (printf "%s;" tname) )
enum_anon :: String -> [ (String, String) ] -> [String]
-enum_anon tag vals = ("enum " ++ tag) >: block [ printf "%s = %s," n v | (n, v) <- vals]
+enum_anon tag vals = ("enum " ++ tag) >: block [ printf "%s = %s," n v | (n, v) <- vals]
-function_proto :: String -> String -> String -> [(String,String)] -> String
-function_proto attr rtype name args =
+function_proto :: String -> String -> String -> [(String,String)] -> String
+function_proto attr rtype name args =
printf "%s %s %s( %s )" attr rtype name (func_args args)
function1 :: String -> String -> String -> [(String,String)] -> [String] -> [String ]
-function1 attr rtype name args body
+function1 attr rtype name args body
= (function_proto attr rtype name args ):(block body)
-
+
static :: String -> String -> [(String,String)] -> [String] -> [ String ]
static rtype name args body = function1 "static" rtype name args body
-
+
inline :: String -> String -> [(String,String)] -> [String] -> [String]
inline rtype name args body =
function1 "static inline" rtype name args body
-
+
func_args:: [(String,String)] -> String
-func_args alist =
+func_args alist =
concat (intersperse ", " [ (n ++ " " ++ v) | (n,v) <- alist ])
multi_comment1 str = [ "", "/*" ] ++ [" * " ++ l | l <- lines str] ++ [ " */"]
indent l = [ " " ++ line | line <- l ]
switch :: String -> [ (String, String) ] -> String -> [String]
-switch disc alts dflt =
- (printf "switch (%s)" disc)
+switch disc alts dflt =
+ (printf "switch (%s)" disc)
>: block ( concat [ [ printf "case %s:" a, printf "%s" l ]
| (a,l) <- alts ]
++ [ "default:", printf "%s" dflt ] )
switch1 :: String -> [ (String,[String]) ] -> [String] -> [String]
-switch1 disc alts dflt =
- (printf "switch (%s)" disc)
+switch1 disc alts dflt =
+ (printf "switch (%s)" disc)
>: (block (concat [ (printf "case %s:" a):l | (a,l) <- alts ] ++ ("default:"):dflt ))
if_stmt :: String -> [String] -> [String]
-if_stmt cond thenclause =
+if_stmt cond thenclause =
(printf "if (%s) " cond):block thenclause
if_else :: String -> [String] -> [String] -> [String]
-if_else cond thenclause elseclause =
+if_else cond thenclause elseclause =
(if_stmt cond thenclause) ++ ("else":(block elseclause))
forloop :: String -> String -> String -> [String] -> [String]
-forloop init iter term body =
+forloop init iter term body =
(printf "for( %s; %s; %s )" init iter term)
>: block body
printf "_rc = %s(s+r, _avail, %s);" fn arg,
"if ( _rc > 0 && _rc < _avail) { r += _rc; }"
]
-
+
snputs :: String -> [ String ]
snputs s = snprintf (printf "\"%%s\", %s" s)
{-
GCBackend: Flounder stub generator for generic code
-
+
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module GCBackend where
bind_cont_name2 ifn = ifscope ifn "bind_contination_multihop"
compile :: String -> String -> Interface -> String
-compile infile outfile interface =
+compile infile outfile interface =
unlines $ C.pp_unit $ stub_body infile interface
stub_body :: String -> Interface -> C.Unit
export_fn_def :: String -> C.Unit
-export_fn_def n =
+export_fn_def n =
C.FunctionDef C.NoScope (C.TypeName "errval_t") (export_fn_name n) params [
localvar (C.Ptr $ C.Struct $ export_type n) "e"
(Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ export_type n]),
C.Return $ C.Call "idc_export_service" [C.AddressOf commonvar]
]
- where
+ where
params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb",
C.Param (C.Ptr $ C.TypeName $ connect_callback_name n) "connect_cb",
drv_connect_callback drv = drv ++ "_connect_callback"
accept_fn_def :: String -> C.Unit
-accept_fn_def n =
+accept_fn_def n =
C.FunctionDef C.NoScope (C.TypeName "errval_t") (accept_fn_name n) params [
C.StmtList [
-- #ifdef CONFIG_FLOUNDER_BACKEND_UMP
]
]
]
- where
+ where
params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var,
C.Param (C.Ptr $ C.TypeName "void") "st",
-- C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb",
connect_fn_def :: String -> C.Unit
-connect_fn_def n =
+connect_fn_def n =
C.FunctionDef C.NoScope (C.TypeName "errval_t") (connect_fn_name n) params [
C.StmtList [
-- #ifdef CONFIG_FLOUNDER_BACKEND_UMP
]
] ]
]
- where
+ where
params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var,
C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
C.Param (C.Ptr $ C.TypeName "void") "st",
bind_fn_def :: String -> C.Unit
-bind_fn_def n =
+bind_fn_def n =
C.FunctionDef C.NoScope (C.TypeName "errval_t") (bind_fn_name n) params [
C.SComment "allocate state",
localvar (C.Ptr $ C.Struct "flounder_generic_bind_attempt") "b"
C.SBlank,
C.Return $ C.Variable "SYS_ERR_OK"
]
- where
+ where
params = [ C.Param (C.TypeName "iref_t") "iref",
C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
C.Param (C.Ptr $ C.TypeName "void") "st",
-- the available bind backends
-- Cation: order of list matters (we will try to bind in that order)
bind_backends :: String -> String -> [BindBackend]
-bind_backends ifn cont_fn_name = map (\i -> i ifn (C.Variable cont_fn_name))
- [lmp_bind_backend,
- ump_ipi_bind_backend,
- ump_bind_backend,
+bind_backends ifn cont_fn_name = map (\i -> i ifn (C.Variable cont_fn_name))
+ [lmp_bind_backend,
+ ump_ipi_bind_backend,
+ ump_bind_backend,
multihop_bind_backend]
-
+
-- backends in different order (prefer multihop over ump, etc.)
multihop_bind_backends :: String -> String -> [BindBackend]
multihop_bind_backends ifn cont_fn_name = map (\i -> i ifn (C.Variable cont_fn_name))
- [lmp_bind_backend,
- multihop_bind_backend,
- ump_ipi_bind_backend,
+ [lmp_bind_backend,
+ multihop_bind_backend,
+ ump_ipi_bind_backend,
ump_bind_backend]
bindst = C.Variable "b"
binding = bindst `C.DerefField` "binding"
-iref = bindst `C.DerefField` "iref"
+iref = bindst `C.DerefField` "iref"
waitset = bindst `C.DerefField` "waitset"
flags = bindst `C.DerefField` "flags"
-lmp_bind_backend ifn cont =
+lmp_bind_backend ifn cont =
BindBackend {
flounder_backend = "lmp",
start_bind = [
(C.Variable "MON_ERR_IDC_BIND_NOT_SAME_CORE"),
cleanup_bind = [ C.Ex $ C.Call "free" [binding] ]
}
-
-ump_bind_backend ifn cont =
+
+ump_bind_backend ifn cont =
BindBackend {
flounder_backend = "ump",
start_bind = [
test_cb_try_next = C.Variable "true",
cleanup_bind = [ C.Ex $ C.Call "free" [binding] ]
}
-
-ump_ipi_bind_backend ifn cont =
+
+ump_ipi_bind_backend ifn cont =
BindBackend {
flounder_backend = "ump_ipi",
start_bind = [
test_cb_try_next = C.Variable "true",
cleanup_bind = [ C.Ex $ C.Call "free" [binding] ]
}
-
-multihop_bind_backend ifn cont =
+
+multihop_bind_backend ifn cont =
BindBackend {
flounder_backend = "multihop",
start_bind = [C.Ex $ C.Assignment binding $
{-
GHBackend: Flounder stub generator for generic header files
-
+
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module GHBackend where
import qualified Backend
import BackendCommon
-accept_fn_name n = ifscope n "accept"
-connect_fn_name n = ifscope n "connect"
+accept_fn_name n = ifscope n "accept"
+connect_fn_name n = ifscope n "connect"
-export_fn_name n = ifscope n "export"
+export_fn_name n = ifscope n "export"
bind_fn_name n = ifscope n "bind"
------------------------------------------------------------------------
------------------------------------------------------------------------
compile :: String -> String -> Interface -> String
-compile infile outfile interface =
+compile infile outfile interface =
unlines $ C.pp_unit $ intf_header_file infile interface
header_file :: String -> Interface -> [C.Unit] -> C.Unit
-header_file infile interface@(Interface name _ _) body =
+header_file infile interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_IF_H"
in
C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
intf_header_file :: String -> Interface -> C.Unit
-intf_header_file infile intf =
+intf_header_file infile intf =
header_file infile intf (intf_header_body infile intf)
intf_header_body :: String -> Interface -> [C.Unit]
-intf_header_body infile interface@(Interface name descr decls) =
+intf_header_body infile interface@(Interface name descr decls) =
let
(types, messagedecls) = Backend.partitionTypesMessages decls
messages = rpcs_to_msgs messagedecls
C.MultiComment [ "Accept function over already shared frame" ],
accept_function name,
C.Blank,
-
+
C.MultiComment [ "The Binding structure" ],
binding_struct name messages,
C.Blank,
C.MultiComment [ "Backend-specific includes" ],
C.UnitList $ backend_includes name,
-
+
C.MultiComment [ "And we're done" ]
]
--
--- Generate an enumeration for each message type, to use as procedure numbers.
+-- Generate an enumeration for each message type, to use as procedure numbers.
--
msg_enums :: String -> [MessageDef] -> C.Unit
msg_enums ifname msgs
--
-- Generate a struct to hold the arguments of a message while it's being sent.
---
+--
msg_argstruct :: String -> [TypeDef] -> MessageDef -> C.Unit
-msg_argstruct ifname typedefs m@(RPC n args _) =
- C.StructDecl (msg_argstruct_name ifname n)
+msg_argstruct ifname typedefs m@(RPC n args _) =
+ C.StructDecl (msg_argstruct_name ifname n)
(concat [ rpc_argdecl ifname a | a <- args ])
msg_argstruct ifname typedefs m@(Message _ n [] _) = C.NoOp
msg_argstruct ifname typedefs m@(Message _ n args _) =
--
-- Generate a union of all the above
---
+--
intf_union :: String -> [MessageDef] -> C.Unit
-intf_union ifn msgs =
+intf_union ifn msgs =
C.UnionDecl (binding_arg_union_type ifn)
([ C.Param (C.Struct $ msg_argstruct_name ifn n) n
| m@(Message _ n a _) <- msgs, 0 /= length a ]
-- Generate a struct defn for a vtable for the interface
--
intf_vtbl :: String -> Direction -> [MessageDef] -> C.Unit
-intf_vtbl n d ml =
+intf_vtbl n d ml =
C.StructDecl (intf_vtbl_type n d) [ intf_vtbl_param n m d | m <- ml ]
intf_vtbl_param :: String -> MessageDef -> Direction -> C.Param
--
--- Generate prototypes for export.
+-- Generate prototypes for export.
--
connect_callback_fn :: String -> C.Unit
-connect_callback_fn n =
- C.TypeDef
- (C.Function C.NoScope (C.TypeName "errval_t") params)
+connect_callback_fn n =
+ C.TypeDef
+ (C.Function C.NoScope (C.TypeName "errval_t") params)
(connect_callback_name n)
where
params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
C.Param (C.Ptr $ C.Void) "st"]
export_function :: String -> C.Unit
-export_function n =
- C.GVarDecl C.Extern C.NonConst
+export_function n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = export_fn_name n
params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb",
C.Param (C.TypeName "idc_export_flags_t") "flags"]
intf_bind_cont_fn :: String -> C.Unit
-intf_bind_cont_fn n =
- C.TypeDef
- (C.Function C.NoScope (C.TypeName "void") params)
+intf_bind_cont_fn n =
+ C.TypeDef
+ (C.Function C.NoScope (C.TypeName "void") params)
(intf_bind_cont_type n)
where
params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
binding_param n ]
can_send_fn_typedef :: String -> C.Unit
-can_send_fn_typedef n =
- C.TypeDef
- (C.Function C.NoScope (C.TypeName "bool") params)
+can_send_fn_typedef n =
+ C.TypeDef
+ (C.Function C.NoScope (C.TypeName "bool") params)
(can_send_fn_type n)
where
params = [ binding_param n ]
register_send_fn_typedef :: String -> C.Unit
-register_send_fn_typedef n =
- C.TypeDef
- (C.Function C.NoScope (C.TypeName "errval_t") params)
+register_send_fn_typedef n =
+ C.TypeDef
+ (C.Function C.NoScope (C.TypeName "errval_t") params)
(register_send_fn_type n)
where
params = [ binding_param n,
C.Param (C.Struct "event_closure") intf_cont_var ]
change_waitset_fn_typedef :: String -> C.Unit
-change_waitset_fn_typedef n =
- C.TypeDef
- (C.Function C.NoScope (C.TypeName "errval_t") params)
+change_waitset_fn_typedef n =
+ C.TypeDef
+ (C.Function C.NoScope (C.TypeName "errval_t") params)
(change_waitset_fn_type n)
where
params = [ binding_param n,
C.Param (C.Ptr $ C.Struct "waitset") "ws" ]
control_fn_typedef :: String -> C.Unit
-control_fn_typedef n =
- C.TypeDef
- (C.Function C.NoScope (C.TypeName "errval_t") params)
+control_fn_typedef n =
+ C.TypeDef
+ (C.Function C.NoScope (C.TypeName "errval_t") params)
(control_fn_type n)
where
params = [ binding_param n,
C.Param (C.TypeName "idc_control_t") "control" ]
error_handler_fn_typedef :: String -> C.Unit
-error_handler_fn_typedef n =
- C.TypeDef
- (C.Function C.NoScope C.Void params)
+error_handler_fn_typedef n =
+ C.TypeDef
+ (C.Function C.NoScope C.Void params)
(error_handler_fn_type n)
where
params = [ binding_param n,
C.Param (C.TypeName "errval_t") "err" ]
bind_function :: String -> C.Unit
-bind_function n =
- C.GVarDecl C.Extern C.NonConst
+bind_function n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = bind_fn_name n
params = [ C.Param (C.TypeName "iref_t") "i",
C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
-- Function for accepting new flounder connections over a already frame
accept_function :: String -> C.Unit
-accept_function n =
- C.GVarDecl C.Extern C.NonConst
+accept_function n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = accept_fn_name n
params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var,
C.Param (C.Ptr $ C.TypeName "void") "st",
C.Param (C.TypeName "idc_export_flags_t") "flags"]
connect_function :: String -> C.Unit
-connect_function n =
- C.GVarDecl C.Extern C.NonConst
+connect_function n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = connect_fn_name n
params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var,
C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
flounder_backends = [ "lmp", "ump", "ump_ipi", "multihop" ]
-backend_includes :: String -> [ C.Unit ]
-backend_includes n =
+backend_includes :: String -> [ C.Unit ]
+backend_includes n =
[ backend_include n b | b <- flounder_backends ]
-backend_include n b =
+backend_include n b =
C.IfDef ("CONFIG_FLOUNDER_BACKEND_" ++ (map toUpper b))
[ C.Include C.Standard ("if/" ++ n ++ "_" ++ b ++ "_defs.h") ]
[]
-----------------------------------------------------------------
define_types :: String -> [TypeDef] -> [C.Unit]
-define_types interfaceName types =
+define_types interfaceName types =
[ define_type interfaceName t | t <- types ]
define_type :: String -> TypeDef -> C.Unit
\end{verbatim}
-}
-define_type ifname (TAlias newType originType) =
+define_type ifname (TAlias newType originType) =
C.TypeDef (type_c_type ifname originType) (type_c_name1 ifname newType)
{-
elements of type @typeElts@. In C, this surprisingly corresponds to
the, correct, following code:
-\begin{verbatim}
+\begin{verbatim}
typedef typeElts name[length]
\end{verbatim}
\end{verbatim}
-}
-define_type ifname (TArray typeElts name length) =
- C.TypeDef
+define_type ifname (TArray typeElts name length) =
+ C.TypeDef
(C.Array length $ type_c_type ifname typeElts)
(type_c_name1 ifname name)
\end{verbatim}
-}
-define_type ifname (TStruct name fields) =
+define_type ifname (TStruct name fields) =
let struct_name = type_c_struct ifname name
type_name = type_c_name1 ifname name
in
- C.UnitList [
- (C.StructDecl struct_name
+ C.UnitList [
+ (C.StructDecl struct_name
[ C.Param (type_c_type ifname ft) fn
| TStructField ft fn <- fields ]),
C.TypeDef (C.Struct struct_name) type_name ]
\end{verbatim}
-}
-define_type ifname (TEnum name elements) =
- C.EnumDecl (type_c_name1 ifname name)
+define_type ifname (TEnum name elements) =
+ C.EnumDecl (type_c_name1 ifname name)
[ C.EnumItem (type_c_enum ifname e) Nothing | e <- elements ]
LMP.hs: Flounder stub generator for local message passing.
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2011, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module LMP where
------------------------------------------------------------------------
header :: String -> String -> Interface -> String
-header infile outfile intf =
+header infile outfile intf =
unlines $ C.pp_unit $ header_file intf (lmp_header_body infile intf)
where
header_file :: Interface -> [C.Unit] -> C.Unit
- header_file interface@(Interface name _ _) body =
+ header_file interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_LMP_H"
in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
]
lmp_init_function_proto :: String -> C.Unit
-lmp_init_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+lmp_init_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope C.Void params) name Nothing
- where
+ where
name = lmp_init_fn_name n
params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b",
C.Param (C.Ptr $ C.Struct "waitset") "waitset"]
lmp_destroy_function_proto :: String -> C.Unit
-lmp_destroy_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+lmp_destroy_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope C.Void params) name Nothing
- where
+ where
name = lmp_destroy_fn_name n
params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b"]
lmp_bind_function_proto :: String -> C.Unit
-lmp_bind_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+lmp_bind_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = lmp_bind_fn_name n
params = lmp_bind_params n
------------------------------------------------------------------------
stub :: Arch -> String -> String -> Interface -> String
-stub arch infile outfile intf =
+stub arch infile outfile intf =
unlines $ C.pp_unit $ lmp_stub_body arch infile intf
lmp_stub_body :: Arch -> String -> Interface -> C.Unit
C.MultiComment [ "Send vtable" ],
tx_vtbl ifn messages,
-
+
C.MultiComment [ "Receive handler" ],
rx_handler arch ifn types messages msg_specs,
C.Blank,
[C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var]] [],
C.Return errvar
]
- where
+ where
params = lmp_bind_params ifn
intf_bind_field = C.FieldOf (C.DerefField lmp_bind_var "b")
C.Ex $ C.CallInd (intf_var `C.FieldOf` "bind_cont")
[intf_var `C.FieldOf` "st", errvar, C.AddressOf intf_var]
]
- where
+ where
params = [C.Param (C.Ptr C.Void) "st",
C.Param (C.TypeName "errval_t") "err",
C.Param (C.Ptr $ C.Struct "lmp_chan") "chan"]
C.If (C.Binary C.Equals lmp_bind_var (C.Variable "NULL"))
[C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [],
C.SBlank,
-
+
localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
intf_bind_var (Just $ C.AddressOf $ lmp_bind_var `C.DerefField` "b"),
C.Ex $ C.Call (lmp_init_fn_name ifn) [lmp_bind_var,
report_user_err errvar,
C.Return $ errvar] [],
C.SBlank,
-
+
C.SComment "register for receive",
C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv"
[chanaddr, C.DerefField bindvar "waitset",
chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan"
change_waitset_fn_def :: String -> C.Unit
-change_waitset_fn_def ifn =
+change_waitset_fn_def ifn =
C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name ifn) params [
localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar),
C.Param (C.Ptr $ C.Struct "waitset") "ws"]
control_fn_def :: String -> C.Unit
-control_fn_def ifn =
+control_fn_def ifn =
C.FunctionDef C.Static (C.TypeName "errval_t") (control_fn_name ifn) params [
localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn)
lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var),
chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan"
flag_arg -- only set the sync flag on the last fragment
| isLast = flag_var
- | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
+ | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
flag_var = C.DerefField lmp_bind_var "flags"
string_arg = argfield_expr TX mn af
pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos"
chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan"
flag_arg -- only set the sync flag on the last fragment
| isLast = flag_var
- | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
+ | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC")
flag_var = C.DerefField lmp_bind_var "flags"
buf_arg = argfield_expr TX mn afn
len_arg = argfield_expr TX mn afl
[]
] [],
C.SBlank,
-
+
C.SComment "is this the start of a new message?",
C.If (C.Binary C.Equals rx_msgnum_field (C.NumConstant 0)) [
C.SComment "check message length",
Loopback.hs: Flounder stub generator for dummy loopback stubs
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module Loopback where
------------------------------------------------------------------------
header :: String -> String -> Interface -> String
-header infile outfile intf@(Interface name descr decls) =
+header infile outfile intf@(Interface name descr decls) =
unlines $ C.pp_unit $ header_file intf header_body
where
header_file :: Interface -> [C.Unit] -> C.Unit
- header_file interface@(Interface name _ _) body =
+ header_file interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_LOOPBACK_H"
in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
loopback_init_function_proto name]
loopback_init_function_proto :: String -> C.Unit
-loopback_init_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+loopback_init_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope C.Void params) name Nothing
where
name = loopback_init_fn_name n
------------------------------------------------------------------------
stub :: String -> String -> Interface -> String
-stub infile outfile intf =
+stub infile outfile intf =
unlines $ C.pp_unit $ loopback_stub_body infile intf
loopback_stub_body :: String -> Interface -> C.Unit
C.MultiComment [ "Send vtable" ],
tx_vtbl ifn messages,
-
+
C.MultiComment [ "Control functions" ],
can_send_fn_def ifn,
register_send_fn_def ifn,
C.Ex $ C.Assignment (common_field "control")
(C.Variable $ generic_control_fn_name drvname ifn)
]
- where
+ where
params = [C.Param (C.Ptr $ C.Struct (intf_bind_type ifn)) intf_bind_var]
common_field f = (C.Variable intf_bind_var) `C.DerefField` f
common_init = binding_struct_init "loopback" ifn
(C.Variable $ loopback_vtbl_name ifn)
can_send_fn_def :: String -> C.Unit
-can_send_fn_def ifn =
+can_send_fn_def ifn =
C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drvname ifn) params [
C.Return $ C.Variable "true"]
where
%if false
Flounder2: an even more simpler IDL for Barrelfish
-
+
Copyright (c) 2009, 2010 ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
> import Text.ParserCombinators.Parsec as Parsec
> import qualified Parser
-> import qualified Syntax
+> import qualified Syntax
> import qualified Arch
> import qualified Backend
> import qualified GHBackend
> addInclude s o = return o { optIncludes = (optIncludes o) ++ [s] }
> options :: [OptDescr (Options -> IO Options)]
-> options = [
+> options = [
> Option ['G'] ["generic-header"] (NoArg $ addTarget GenericHeader) "Create a generic header file",
> Option [] ["generic-stub"] (NoArg $ addTarget GenericCode) "Create generic part of stub implemention",
> Option ['a'] ["arch"] (ReqArg setArch "ARCH") "Architecture for stubs",
> if ifacename == takeBaseName fname then return () else ioError $ userError ("Interface name '" ++ ifacename ++ "' has to equal filename in " ++ fname)
> main :: IO ()
-> main = do
+> main = do
> argv <- System.Environment.getArgs
> case getOpt RequireOrder options argv of
> (optf, [ inFile, outFile ], []) -> do
message buffers
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module MsgBuf where
------------------------------------------------------------------------
header :: String -> String -> Interface -> String
-header infile outfile intf =
+header infile outfile intf =
unlines $ C.pp_unit $ header_file intf (header_body infile intf)
where
header_file :: Interface -> [C.Unit] -> C.Unit
- header_file interface@(Interface name _ _) body =
+ header_file interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_MSGBUF_STUB_H"
in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
(types, msgs) = Backend.partitionTypesMessages decls
tx_fn_proto :: String -> MessageDef -> C.Unit
-tx_fn_proto ifn msg =
+tx_fn_proto ifn msg =
C.GVarDecl C.NoScope C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") (tx_fn_params ifn msg))
(tx_fn_name ifn (msg_name msg)) Nothing
++ concat [ msg_argdecl TX ifn a | a <- args ]
rx_fn_proto :: String -> C.Unit
-rx_fn_proto ifn =
- C.GVarDecl C.NoScope C.NonConst
+rx_fn_proto ifn =
+ C.GVarDecl C.NoScope C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") (rx_fn_params ifn))
(rx_fn_name ifn) Nothing
marshall_arg a = error $ "complex types are NYI for MsgBuf backend: " ++ show a
rx_fn :: String -> [MessageDef] -> C.Unit
-rx_fn ifn msgs =
+rx_fn ifn msgs =
C.FunctionDef C.NoScope (C.TypeName "errval_t") (rx_fn_name ifn) (rx_fn_params ifn)
[
localvar (C.TypeName "errval_t") errvar_name Nothing,
multiple fragments.
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module MsgFragments where
-- some fragments are "special" in that they can overflow and occupy an
-- arbitrary number of underlying transport messages, because their size is
-- only known at run time
-data OverflowFragment =
+data OverflowFragment =
-- for marshalling byte arrays: type, data pointer and length fields
BufferFragment TypeBuiltin ArgField ArgField
-- for marshalling strings: string pointer field
deriving (Show, Eq)
-- a capability is just identified by the name of its field
-type CapField = ArgField
+type CapField = ArgField
--- a capability transfer is identified by the name of its field and the type
+-- a capability transfer is identified by the name of its field and the type
-- of transfer requested
data CapFieldTransfer = CapFieldTransfer CapTransferMode ArgField
deriving (Show, Eq)
Multihop.hs: Flounder stub generator for multihop message passing.
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module Multihop(stub, header, m_bind_type, m_bind_fn_name) where
-- create the header file
header :: String -> String -> Interface -> String
-header infile outfile intf =
+header infile outfile intf =
unlines $ C.pp_unit $ header_file intf (multihop_header_body infile intf)
where
header_file :: Interface -> [C.Unit] -> C.Unit
- header_file interface@(Interface name _ _) body =
+ header_file interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_MULTIHOP_H"
in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
C.Param (C.Struct $ intf_bind_type ifn) "b",
C.Param (C.Struct "multihop_chan") "chan",
C.Param (C.Ptr C.Void) "message",
- C.Param (C.Struct "flounder_cap_state") "capst",
+ C.Param (C.Struct "flounder_cap_state") "capst",
C.Param (C.TypeName "bool") "trigger_chan"]
multihop_init_function_proto :: String -> C.Unit
-multihop_init_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+multihop_init_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope C.Void params) name Nothing
- where
+ where
name = multihop_init_fn_name n
params = [C.Param (C.Ptr $ C.Struct (m_bind_type n)) "b",
C.Param (C.Ptr $ C.Struct "waitset") "waitset"]
multihop_destroy_function_proto :: String -> C.Unit
-multihop_destroy_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+multihop_destroy_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope C.Void params) name Nothing
- where
+ where
name = multihop_destroy_fn_name n
params = [C.Param (C.Ptr $ C.Struct (m_bind_type n)) "b"]
multihop_bind_function_proto :: String -> C.Unit
-multihop_bind_function_proto n =
- C.GVarDecl C.Extern C.NonConst
+multihop_bind_function_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = m_bind_fn_name n
params = multihop_bind_params n
fieldaccessor _ af = argfield_expr TX mn af
stub :: Arch -> String -> String -> Interface -> String
-stub arch infile outfile intf =
+stub arch infile outfile intf =
unlines $ C.pp_unit $ multihop_stub_body arch infile intf
multihop_stub_body :: Arch -> String -> Interface -> C.Unit
C.Include C.Standard "flounder/flounder_support.h",
C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"),
C.Blank,
-
+
C.MultiComment [ "Capability sender function" ],
- (if (contains_caps) then
+ (if (contains_caps) then
(tx_cap_handler arch ifn msg_specs) else C.Blank),
C.MultiComment [ "Send handler functions" ],
C.MultiComment [ "Send vtable" ],
tx_vtbl ifn messages,
-
+
C.MultiComment [ "Receive handler" ],
rx_handler m_arch ifn types messages msg_specs,
C.Blank,
msg_specs :: [MsgSpec]
msg_specs = map (build_msg_spec m_arch words_per_frag True types) messages
-
+
-- number of words per transport level message
words_per_frag = msg_payload `div` (wordsize arch `div` 8)
-- bind function
multihop_bind_fn :: String -> C.Unit
multihop_bind_fn ifn =
- C.FunctionDef C.NoScope (C.TypeName "errval_t") (m_bind_fn_name ifn) params
+ C.FunctionDef C.NoScope (C.TypeName "errval_t") (m_bind_fn_name ifn) params
[
localvar (C.TypeName "errval_t") "err" Nothing,
C.Ex $ C.Call (multihop_init_fn_name ifn) [multihop_bind_var, C.Variable "waitset"],
[C.Ex $ C.Call (multihop_destroy_fn_name ifn) [multihop_bind_var]] [],
C.Return errvar
]
- where
+ where
params = multihop_bind_params ifn
intf_bind_field = C.FieldOf (C.DerefField multihop_bind_var "b")
-- bind continue function
multihop_bind_cont_fn :: String -> C.Unit
multihop_bind_cont_fn ifn =
- C.FunctionDef C.Static C.Void (multihop_bind_cont_fn_name ifn) params
+ C.FunctionDef C.Static C.Void (multihop_bind_cont_fn_name ifn) params
[
localvar (C.Ptr $ C.Struct $ m_bind_type ifn)
multihop_bind_var_name (Just $ C.Variable "st"),
C.If (C.Call "err_is_ok" [errvar])
[C.SComment "set receive handlers",
- C.Ex $ C.Call "multihop_chan_set_receive_handler"
+ C.Ex $ C.Call "multihop_chan_set_receive_handler"
[C.AddressOf $ C.DerefField multihop_bind_var "chan",
- C.StructConstant "multihop_receive_handler"
- [("handler", C.Variable (rx_handler_name ifn)),
+ C.StructConstant "multihop_receive_handler"
+ [("handler", C.Variable (rx_handler_name ifn)),
("arg", C.Variable "st") ] ],
-
+
C.Ex $ C.Call ("multihop_chan_set_caps_receive_handlers")
[C.AddressOf $ C.DerefField multihop_bind_var "chan",
C.StructConstant "monitor_cap_handlers"
[("st", C.Variable "st"),
("cap_receive_handler", C.Variable (caps_rx_handler_name ifn))
]]]
-
+
[ C.Ex $ C.Call (multihop_destroy_fn_name ifn) [multihop_bind_var]],
C.SBlank,
C.Ex $ C.CallInd (intf_var `C.FieldOf` "bind_cont")
- [intf_var `C.FieldOf` "st", errvar, C.AddressOf intf_var]
+ [intf_var `C.FieldOf` "st", errvar, C.AddressOf intf_var]
]
- where
+ where
params = [C.Param (C.Ptr C.Void) "st",
C.Param (C.TypeName "errval_t") "err",
C.Param (C.Ptr $ C.Struct "multihop_chan") "chan"]
chanaddr = C.Variable "chan"
multihop_connect_handler_fn :: String -> C.Unit
-multihop_connect_handler_fn ifn =
+multihop_connect_handler_fn ifn =
C.FunctionDef C.NoScope (C.TypeName "errval_t")
- (drv_connect_handler_name "multihop" ifn) multihop_connect_handler_params
+ (drv_connect_handler_name "multihop" ifn) multihop_connect_handler_params
[
localvar (C.Ptr $ C.Struct $ export_type ifn) "e" $ Just $ C.Variable "st",
localvar (C.TypeName "errval_t") "err" Nothing,
C.If (C.Binary C.Equals multihop_bind_var (C.Variable "NULL"))
[C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [],
C.SBlank,
-
+
C.SComment "initialize binding",
localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
intf_bind_var (Just $ C.AddressOf $ multihop_bind_var `C.DerefField` "b"),
[C.Return errvar ] [],
C.SBlank,
- C.SComment "set receive handlers",
- C.Ex $ C.Call ("multihop_chan_set_receive_handler")
+ C.SComment "set receive handlers",
+ C.Ex $ C.Call ("multihop_chan_set_receive_handler")
[C.AddressOf $ C.DerefField multihop_bind_var "chan",
- C.StructConstant "multihop_receive_handler"
- [("handler", C.Variable (rx_handler_name ifn)),
+ C.StructConstant "multihop_receive_handler"
+ [("handler", C.Variable (rx_handler_name ifn)),
("arg", multihop_bind_var) ] ],
-
-
+
+
C.Ex $ C.Call ("multihop_chan_set_caps_receive_handlers")
[C.AddressOf $ C.DerefField multihop_bind_var "chan",
C.StructConstant "monitor_cap_handlers"
("cap_receive_handler", C.Variable (caps_rx_handler_name ifn))
]],
C.SBlank,
-
+
C.SComment "send back bind reply",
C.Ex $ C.Call ("multihop_chan_send_bind_reply")
- [C.AddressOf $ C.DerefField multihop_bind_var "chan",
- C.Variable "SYS_ERR_OK" ,
- C.FieldOf (C.DerefField multihop_bind_var "chan") "vci",
+ [C.AddressOf $ C.DerefField multihop_bind_var "chan",
+ C.Variable "SYS_ERR_OK" ,
+ C.FieldOf (C.DerefField multihop_bind_var "chan") "vci",
C.FieldOf (C.DerefField multihop_bind_var "b") "waitset" ],
-
+
C.SBlank,
C.Return $ C.Variable "err"
]
-- Language mapping: Control functions
------------------------------------------------------------------------
m_can_send_fn_def :: String -> String -> C.Unit
-m_can_send_fn_def drv ifn =
+m_can_send_fn_def drv ifn =
C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drv ifn) params [
localvar (C.Ptr $ C.Struct $ m_bind_type ifn)
multihop_bind_var_name (Just $ C.Cast (C.Ptr $ C.Struct $ m_bind_type ifn) (bindvar)),
change_waitset_fn_def :: String -> C.Unit
-change_waitset_fn_def ifn =
+change_waitset_fn_def ifn =
C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name ifn) params [
localvar (C.Ptr $ C.Struct $ m_bind_type ifn)
multihop_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar),
C.Param (C.Ptr $ C.Struct "waitset") "ws"]
control_fn_def :: String -> C.Unit
-control_fn_def ifn =
+control_fn_def ifn =
C.FunctionDef C.Static (C.TypeName "errval_t") (control_fn_name ifn) params [
C.SComment "No control flags supported",
where
params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var,
C.Param (C.TypeName "idc_control_t") "control"]
-
+
------------------------------------------------------------------------
-- Language mapping: Send messages
------------------------------------------------------------------------
-- get all fixed size fragments
get_fixed_frags frags = [ x | x@(MsgFragment {}) <- frags ]
-get_overflow_frags frags = [ x | x@(OverflowFragment {}) <- frags ]
+get_overflow_frags frags = [ x | x@(OverflowFragment {}) <- frags ]
tx_handler :: Arch -> String -> MsgSpec -> C.Unit
tx_handler arch ifn (MsgSpec mn msgfrags caps) =
- C.FunctionDef C.Static C.Void (tx_handler_name ifn mn) [C.Param (C.Ptr C.Void) "arg"]
+ C.FunctionDef C.Static C.Void (tx_handler_name ifn mn) [C.Param (C.Ptr C.Void) "arg"]
[
handler_preamble ifn,
localvar (C.TypeName "errval_t") "err" (Just $ C.Variable "SYS_ERR_OK"),
localvar (C.Ptr $ wordsize_type) "msg" Nothing,
localvar (C.TypeName "uint64_t") "msg_size" Nothing,
-
+
-- we only need those variables of there are any dynamic arguments
- (if (not $ null (get_overflow_frags msgfrags)) then
- C.StmtList
+ (if (not $ null (get_overflow_frags msgfrags)) then
+ C.StmtList
[localvar (C.Ptr $ C.TypeName "uint8_t") "msg2" Nothing,
localvar (C.TypeName "uint64_t") "o_frag_size" Nothing]
else C.SBlank),
report_user_tx_err errvar
]
where
-
+
-- case for unknown message fragment
bad = [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "invalid fragment"],
C.Ex $ C.Assignment errvar (C.Variable "FLOUNDER_ERR_INVALID_STATE")]
cases =
- [C.Case (C.NumConstant 0) (tx_frags arch ifn mn msgfrags)]
+ [C.Case (C.NumConstant 0) (tx_frags arch ifn mn msgfrags)]
++ [gen_last 1]
-
+
-- generate the last case
gen_last i
- | null caps = -- this message does not contain caps
- C.Case (C.NumConstant $ toInteger $ i)
+ | null caps = -- this message does not contain caps
+ C.Case (C.NumConstant $ toInteger $ i)
([C.SComment "all fragments are sent",
C.Ex $ C.Call "free" [C.DerefField multihop_bind_var "message"]]
- ++ [C.If (C.Call "multihop_chan_is_window_full" [C.AddressOf $ C.DerefField multihop_bind_var "chan"])
+ ++ [C.If (C.Call "multihop_chan_is_window_full" [C.AddressOf $ C.DerefField multihop_bind_var "chan"])
[C.Ex $ C.Assignment (C.DerefField multihop_bind_var "trigger_chan") (C.Variable "true"),
C.ReturnVoid]
([C.StmtList finished_send] ++ [C.ReturnVoid])])
C.Case (C.NumConstant $ toInteger $ i)
([C.Ex $ C.Call "free" [C.DerefField multihop_bind_var "message"],
C.SComment "send caps",
- C.Ex $ C.Call (cap_tx_handler_name ifn) [multihop_bind_var], C.ReturnVoid])
-
+ C.Ex $ C.Call (cap_tx_handler_name ifn) [multihop_bind_var], C.ReturnVoid])
+
-- field for the message number
- tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
+ tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
-- send an message (including all overflow fragemnts)
tx_frags :: Arch -> String -> String -> [MsgFragment] ->[C.Stmt]
-tx_frags arch ifn mn frags =
+tx_frags arch ifn mn frags =
[
C.SComment "Calculate size of message & allocate it",
-
- C.Ex $ C.Assignment (C.Variable "msg_size")
+
+ C.Ex $ C.Assignment (C.Variable "msg_size")
(C.NumConstant $ message_size (length words)) ,
-
+
-- calculate size of strings
C.StmtList
- [C.Ex $ C.Assignment (C.Variable "msg_size")
- (C.Binary C.Plus (C.Binary C.Plus (C.Variable "msg_size")
- (C.Call "strlen" [argfield_expr TX mn argfield]))
- (C.NumConstant (1 + m_size_type_bytes)))
+ [C.Ex $ C.Assignment (C.Variable "msg_size")
+ (C.Binary C.Plus (C.Binary C.Plus (C.Variable "msg_size")
+ (C.Call "strlen" [argfield_expr TX mn argfield]))
+ (C.NumConstant (1 + m_size_type_bytes)))
| (OverflowFragment (StringFragment argfield)) <- frags ],
-
+
-- calculate size of buffers
C.StmtList
[C.Ex $ C.Assignment (C.Variable "msg_size")
- (C.Binary C.Plus (C.Variable "msg_size")
+ (C.Binary C.Plus (C.Variable "msg_size")
(C.Binary C.Plus (argfield_expr TX mn l) (C.NumConstant m_size_type_bytes)))
| (OverflowFragment (BufferFragment t d l)) <- frags ],
-
+
-- make sure that the message size is not zero
C.Ex $ C.Call "assert" [C.Binary C.NotEquals (C.Variable "msg_size") (C.NumConstant 0)],
-
+
-- malloc message
C.Ex $ C.Assignment (C.Variable "msg") (C.Call "malloc" [C.Variable "msg_size"]),
C.SBlank,
C.StmtList
[C.Ex $ C.Assignment (msgword n) (m_fragment_word_to_expr arch ifn mn (words !! n))
| n <- [0 .. length words - 1]],
- (if (not $ null $ overflow_frags) then
- C.Ex $ C.Assignment (C.Variable "msg2")
- (C.Binary C.Plus (C.Cast (C.Ptr $ C.TypeName "uint8_t") (C.Variable "msg"))
+ (if (not $ null $ overflow_frags) then
+ C.Ex $ C.Assignment (C.Variable "msg2")
+ (C.Binary C.Plus (C.Cast (C.Ptr $ C.TypeName "uint8_t") (C.Variable "msg"))
(C.NumConstant $ message_size (length words)))
else C.SBlank),
C.SBlank,
C.StmtList $
concat [ copy_buf b | (OverflowFragment b@(BufferFragment {})) <- frags],
C.SBlank,
-
+
-- send message
C.SComment "try to send!",
C.Ex $ C.PostInc $ C.DerefField bindvar "tx_msg_fragment",
C.Ex $ C.Assignment (C.DerefField multihop_bind_var "message") (C.Variable "msg"),
- C.Ex $ C.Assignment (C.Variable "err")
- (C.Call "multihop_send_message" [C.AddressOf $ C.DerefField multihop_bind_var "chan",
- C.Call "MKCONT" [C.Variable $ (tx_handler_name ifn mn) ,
- C.Variable intf_bind_var],
- C.Variable "msg",
+ C.Ex $ C.Assignment (C.Variable "err")
+ (C.Call "multihop_send_message" [C.AddressOf $ C.DerefField multihop_bind_var "chan",
+ C.Call "MKCONT" [C.Variable $ (tx_handler_name ifn mn) ,
+ C.Variable intf_bind_var],
+ C.Variable "msg",
C.Variable "msg_size"]),
-
+
-- make sure send was successful
C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "FLOUNDER_ERR_TX_BUSY"))
[C.Ex $ C.PostDec $ C.DerefField bindvar "tx_msg_fragment",
- C.Ex $ C.Assignment (C.Variable "err")
- (C.Call "multihop_chan_register_send" [C.AddressOf $ C.DerefField multihop_bind_var "chan",
+ C.Ex $ C.Assignment (C.Variable "err")
+ (C.Call "multihop_chan_register_send" [C.AddressOf $ C.DerefField multihop_bind_var "chan",
C.DerefField (C.Variable intf_bind_var) "waitset",
- C.Call "MKCONT" [C.Variable $ (tx_handler_name ifn mn) ,
+ C.Call "MKCONT" [C.Variable $ (tx_handler_name ifn mn) ,
C.Variable intf_bind_var]]),
C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]]
[],
C.If (C.Call "err_is_fail" [errvar]) [C.Break] [C.ReturnVoid]
]
where
-
+
words = concat [f | (MsgFragment f) <- frags]
-- the fixed size fragments in this message
msgword n = (C.Variable "msg") `C.SubscriptOf` (C.NumConstant $ toInteger n)
message_size words = toInteger $ words * (wordsize m_arch `div` 8)
-
+
-- copy a string
- copy_string :: ArgField -> [C.Stmt]
- copy_string argfield =
+ copy_string :: ArgField -> [C.Stmt]
+ copy_string argfield =
[
- C.Ex $ C.Assignment (C.Variable "o_frag_size")
+ C.Ex $ C.Assignment (C.Variable "o_frag_size")
(C.Cast m_size_type (C.Call "strlen" [argfield_expr TX mn argfield])),
- C.Ex $ C.Call "memcpy" [C.Variable "msg2",
+ C.Ex $ C.Call "memcpy" [C.Variable "msg2",
C.AddressOf $ C.Variable "o_frag_size", C.NumConstant m_size_type_bytes ],
- C.Ex $ C.Call "memcpy" [C.Binary C.Plus (C.Variable "msg2")
- (C.NumConstant m_size_type_bytes),
- argfield_expr TX mn argfield,
+ C.Ex $ C.Call "memcpy" [C.Binary C.Plus (C.Variable "msg2")
+ (C.NumConstant m_size_type_bytes),
+ argfield_expr TX mn argfield,
C.Variable "o_frag_size"],
- C.Ex $ C.Assignment (C.Variable "msg2") (C.Binary C.Plus
- (C.Binary C.Plus (C.Variable "msg2")
- (C.Variable "o_frag_size"))
+ C.Ex $ C.Assignment (C.Variable "msg2") (C.Binary C.Plus
+ (C.Binary C.Plus (C.Variable "msg2")
+ (C.Variable "o_frag_size"))
(C.NumConstant m_size_type_bytes))
]
-- copy a buffer
copy_buf :: OverflowFragment -> [C.Stmt]
- copy_buf (BufferFragment t d l) =
+ copy_buf (BufferFragment t d l) =
[
C.Ex $ C.Assignment (C.Variable "o_frag_size") (C.Cast m_size_type (argfield_expr TX mn l)),
- C.Ex $ C.Call "memcpy" [C.Variable "msg2",
+ C.Ex $ C.Call "memcpy" [C.Variable "msg2",
C.AddressOf $ C.Variable "o_frag_size", C.NumConstant m_size_type_bytes ],
- C.Ex $ C.Call "memcpy" [C.Binary C.Plus (C.Variable "msg2")
+ C.Ex $ C.Call "memcpy" [C.Binary C.Plus (C.Variable "msg2")
(C.NumConstant m_size_type_bytes), argfield_expr TX mn d, C.Variable "o_frag_size"],
- C.Ex $ C.Assignment (C.Variable "msg2") (C.Binary C.Plus
- (C.Binary C.Plus (C.Variable "msg2")
- (C.Variable "o_frag_size"))
+ C.Ex $ C.Assignment (C.Variable "msg2") (C.Binary C.Plus
+ (C.Binary C.Plus (C.Variable "msg2")
+ (C.Variable "o_frag_size"))
(C.NumConstant m_size_type_bytes))
]
params = [binding_param ifn, cont_param] ++ (
concat [ msg_argdecl TX ifn a | a <- args ])
cont_param = C.Param (C.Struct "event_closure") intf_cont_var
- body =
+ body =
[
C.SComment "check that we can accept an outgoing message",
C.If (C.Binary C.NotEquals tx_msgnum_field (C.NumConstant 0))
C.SComment "register send continuation",
C.StmtList $ register_txcont (C.Variable intf_cont_var),
C.SBlank,
-
+
C.SComment "store message number and the arguments",
C.Ex $ C.Assignment tx_msgnum_field (C.Variable $ msg_enum_elem_name ifn n),
C.Ex $ C.Assignment tx_msgfrag_field (C.NumConstant 0),
C.SBlank,
C.Return $ C.Variable "SYS_ERR_OK"
]
-
+
tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
tx_msgfrag_field = C.DerefField bindvar "tx_msg_fragment"
-- send capabilities
tx_cap_handler :: Arch -> String -> [MsgSpec] -> C.Unit
-tx_cap_handler arch ifn msgspecs =
+tx_cap_handler arch ifn msgspecs =
C.FunctionDef C.Static C.Void (cap_tx_handler_name ifn) [C.Param (C.Ptr C.Void) "arg"] [
handler_preamble ifn,
localvar (C.TypeName "errval_t") "err" (Just (C.Variable "SYS_ERR_OK")),
where
capst = C.DerefField multihop_bind_var "capst"
cases = [C.Case (C.NumConstant $ toInteger i) $ subcase cap i
- | (cap, i) <- zip caps [0..]] ++
+ | (cap, i) <- zip caps [0..]] ++
[C.Case (C.NumConstant $ toInteger $ length caps) last_case]
- last_case =
+ last_case =
-- if we've sent the last cap, and we've sent all the other fragments, we're done
- [C.If (C.Call "multihop_chan_is_window_full" [C.AddressOf $ C.DerefField multihop_bind_var "chan"])
+ [C.If (C.Call "multihop_chan_is_window_full" [C.AddressOf $ C.DerefField multihop_bind_var "chan"])
[C.Ex $ C.Assignment (C.DerefField multihop_bind_var "trigger_chan") (C.Variable "true"),
C.Break]
([C.StmtList finished_send] ++ [C.Break])]
-
+
tx_msgfrag_field = C.DerefField bindvar "tx_msg_fragment"
subcase :: CapFieldTransfer -> Int -> [C.Stmt]
subcase (CapFieldTransfer tm cap) ncap = [
C.Ex $ C.Assignment errvar $ C.Call "multihop_send_capability"
- [C.AddressOf $ C.DerefField multihop_bind_var "chan",
+ [C.AddressOf $ C.DerefField multihop_bind_var "chan",
C.Call "MKCONT" [C.Variable $ (cap_tx_handler_name ifn) , C.Variable intf_bind_var],
C.AddressOf capst, argfield_expr TX mn cap],
-
+
C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "FLOUNDER_ERR_TX_BUSY"))
- [C.Ex $ C.Assignment (C.Variable "err")
- (C.Call "multihop_chan_register_send" [C.AddressOf $ C.DerefField multihop_bind_var "chan",
+ [C.Ex $ C.Assignment (C.Variable "err")
+ (C.Call "multihop_chan_register_send" [C.AddressOf $ C.DerefField multihop_bind_var "chan",
C.DerefField (C.Variable intf_bind_var) "waitset",
- C.Call "MKCONT" [C.Variable $ (cap_tx_handler_name ifn) ,
+ C.Call "MKCONT" [C.Variable $ (cap_tx_handler_name ifn) ,
C.Variable intf_bind_var]]),
C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]]
[],
-
+
C.If (C.Call "err_is_fail" [errvar])
[report_user_tx_err errvar, C.Break] [],
C.Break]
rx_handler :: Arch -> String -> [TypeDef] -> [MessageDef] -> [MsgSpec] -> C.Unit
rx_handler arch ifn typedefs msgdefs msgs =
- C.FunctionDef C.NoScope C.Void (rx_handler_name ifn) multihop_rx_handler_params
+ C.FunctionDef C.NoScope C.Void (rx_handler_name ifn) multihop_rx_handler_params
[
handler_preamble ifn,
(if (contains_overflow_frags)
else C.SBlank),
localvar (C.Ptr $ C.TypeName "uint8_t") "msg" Nothing,
C.SBlank,
-
+
C.SComment "if this a dummy message?",
C.If (C.Binary C.Equals (C.Variable "message_len") (C.NumConstant 0))
[C.If (C.DerefField multihop_bind_var "trigger_chan")
[C.Ex $ C.Assignment (C.DerefField multihop_bind_var "trigger_chan") (C.Variable "false"),
- C.StmtList finished_send] [], C.ReturnVoid
+ C.StmtList finished_send] [], C.ReturnVoid
] [],
-
+
C.SComment "is this the start of a new message?",
C.If (C.Binary C.Equals rx_msgnum_field (C.NumConstant 0)) [
C.SComment "unmarshall message number from first word, set fragment to 0",
C.Ex $ C.Assignment rx_msgnum_field $
C.Binary C.BitwiseAnd (C.SubscriptOf msgwords $ C.NumConstant 0) msgnum_mask,
C.Ex $ C.Assignment rx_msgfrag_field (C.NumConstant 0),
- C.Ex $ C.Assignment rx_capnum_field (C.NumConstant 0)]
+ C.Ex $ C.Assignment rx_capnum_field (C.NumConstant 0)]
[C.Ex $ C.Call "assert" [C.Unary C.Not (C.Variable "\"should not happen\"") ]],
C.SBlank,
-
+
C.SComment "switch on message number",
C.Switch rx_msgnum_field msgnum_cases bad_msgnum
]
where
-
+
contains_overflow_frags :: Bool
- contains_overflow_frags = not $ null $ concat $ map
+ contains_overflow_frags = not $ null $ concat $ map
(\ ( MsgSpec _ frags _ ) -> [ f | f@(OverflowFragment _) <- frags]) msgs
-
+
msgwords = C.Variable "message"
msgnum_bits = bitsizeof_argfieldfrag arch MsgCode
msgnum_mask = C.HexConstant ((shift 1 msgnum_bits) - 1)
-- generate code to receive the different message types
msgnum_cases :: [C.Case]
- msgnum_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn)
+ msgnum_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn)
(rx_handler_msg arch ifn typedefs msgdef msg)
| (msgdef, msg@(MsgSpec mn _ _)) <- zip msgdefs msgs]
C.SComment "store fixed size fragments",
C.StmtList $ concat [store_arg_frags arch ifn mn msgExpr word 0 afl
| (afl, word) <- zip words [0..]],
-
+
C.Ex $ C.Assignment (C.Variable "msg") (C.Binary C.Plus (C.Variable "message")
(C.NumConstant $ message_size $ length words)),
C.SBlank,
msgfrag_case_prolog ifn typedefs msgdef (null caps),
C.Break
]
-
+
where
words = concat [f | (MsgFragment f) <- frags]
msgExpr = C.Cast (C.Ptr $ wordsize_type) (C.Variable "message")
-
+
-- calculate the size of the message from the number of words
message_size :: Int -> Integer
message_size words = toInteger $ words * (wordsize m_arch `div` 8)
-
+
-- handle invalide message fragment
bad_msgfrag :: [C.Stmt]
bad_msgfrag = [report_user_err $ C.Variable "FLOUNDER_ERR_INVALID_STATE", C.ReturnVoid]
-- receive a string
receive_string :: OverflowFragment -> [C.Stmt]
- receive_string (StringFragment argfield) =
+ receive_string (StringFragment argfield) =
[
C.Ex $ C.Assignment (C.Variable "o_frag_size") (C.NumConstant 0),
- C.Ex $ C.Call "memcpy" [C.AddressOf $ C.Variable "o_frag_size",
+ C.Ex $ C.Call "memcpy" [C.AddressOf $ C.Variable "o_frag_size",
C.Variable "msg",
C.NumConstant m_size_type_bytes ],
C.Ex $ C.Assignment (argfield_expr RX mn argfield)
(C.Call "malloc" [C.Binary C.Plus (C.Variable "o_frag_size") (C.NumConstant 1)]),
- C.Ex $ C.Call "memcpy" [argfield_expr RX mn argfield,
- C.Binary C.Plus (C.Variable "msg")
+ C.Ex $ C.Call "memcpy" [argfield_expr RX mn argfield,
+ C.Binary C.Plus (C.Variable "msg")
(C.NumConstant m_size_type_bytes),
C.Variable "o_frag_size"],
C.Ex $ C.Assignment (argfield_expr RX mn argfield `C.SubscriptOf` (C.Variable "o_frag_size")) (C.NumConstant 0),
C.Ex $ C.Assignment (C.Variable "msg") (C.Binary C.Plus
- (C.Binary C.Plus (C.Variable "msg")
+ (C.Binary C.Plus (C.Variable "msg")
(C.Variable "o_frag_size"))
(C.NumConstant m_size_type_bytes))
]
-- receive a buffer
receive_buf :: OverflowFragment -> [C.Stmt]
- receive_buf (BufferFragment t d l) =
+ receive_buf (BufferFragment t d l) =
[
C.Ex $ C.Assignment (C.Variable "o_frag_size") (C.NumConstant 0),
- C.Ex $ C.Call "memcpy" [C.AddressOf $ C.Variable "o_frag_size",
+ C.Ex $ C.Call "memcpy" [C.AddressOf $ C.Variable "o_frag_size",
C.Variable "msg",
C.NumConstant m_size_type_bytes ],
- C.Ex $ C.Assignment (argfield_expr RX mn d)
+ C.Ex $ C.Assignment (argfield_expr RX mn d)
(C.Call "malloc" [C.Variable "o_frag_size"]),
- C.Ex $ C.Call "memcpy" [argfield_expr RX mn d,
- C.Binary C.Plus (C.Variable "msg")
+ C.Ex $ C.Call "memcpy" [argfield_expr RX mn d,
+ C.Binary C.Plus (C.Variable "msg")
(C.NumConstant m_size_type_bytes),
C.Variable "o_frag_size"],
- C.Ex $ C.Assignment (argfield_expr RX mn l)
- (C.Cast (C.TypeName "size_t") (C.Variable "o_frag_size")),
+ C.Ex $ C.Assignment (argfield_expr RX mn l)
+ (C.Cast (C.TypeName "size_t") (C.Variable "o_frag_size")),
C.Ex $ C.Assignment (C.Variable "msg") (C.Binary C.Plus
- (C.Binary C.Plus (C.Variable "msg")
+ (C.Binary C.Plus (C.Variable "msg")
(C.Variable "o_frag_size"))
(C.NumConstant m_size_type_bytes))
]
msgfrag_case_prolog :: String -> [TypeDef] -> MessageDef -> Bool -> C.Stmt
-
+
-- intermediate fragment
msgfrag_case_prolog _ _ _ False
= C.Ex $ C.PostInc $ C.DerefField bindvar "rx_msg_fragment"
-- last fragment: call handler and zero message number
msgfrag_case_prolog ifn typedefs (Message _ mn msgargs _) True
= C.StmtList $ finished_recv drvname ifn typedefs mn msgargs
-
+
-- receive caps
caps_rx_handler :: Arch -> String -> [TypeDef] -> [MessageDef] -> [MsgSpec] -> C.Unit
caps_rx_handler arch ifn typedefs msgdefs msgs =
- C.FunctionDef C.NoScope C.Void (caps_rx_handler_name ifn) multihop_caps_rx_handler_params
+ C.FunctionDef C.NoScope C.Void (caps_rx_handler_name ifn) multihop_caps_rx_handler_params
[
handler_preamble ifn,
C.SBlank,
C.Ex $ C.Call "assert" [C.Binary C.Equals (C.Variable "capid") (capst `C.FieldOf` "rx_capnum")],
- C.SBlank,
-
+ C.SBlank,
+
C.SComment "Check if there's an associated error",
C.SComment "FIXME: how should we report this to the user? at present we just deliver a NULL capref",
C.If (C.Call "err_is_fail" [C.Variable "success"])
- [C.Ex $ C.Call "DEBUG_ERR"
+ [C.Ex $ C.Call "DEBUG_ERR"
[C.Variable "success", C.StringConstant "could not send cap over multihop channel"]
] [],
C.SBlank,
-- receive the capabilities of one message
cap_rx_handler_case :: Arch -> String -> [TypeDef] -> String -> MessageDef -> Int -> [CapFieldTransfer] -> [C.Stmt]
-cap_rx_handler_case arch ifn typedefs mn (Message _ _ msgargs _) nfrags caps =
+cap_rx_handler_case arch ifn typedefs mn (Message _ _ msgargs _) nfrags caps =
[
C.SComment "Switch on current incoming cap",
C.Switch (C.PostInc $ capst `C.FieldOf` "rx_capnum") cases
C.Break]
where
capst = C.DerefField multihop_bind_var "capst"
-
+
cases = [C.Case (C.NumConstant $ toInteger i) $ subcase cap i
| (cap, i) <- zip caps [0..]]
C.Break]
where
rx_msgfrag_field = C.DerefField bindvar "rx_msg_fragment"
-
+
is_last = (ncap + 1 == length caps)
{-
-
+
Parser.hs: Parser for the Flounder interface definition language
-
+
Part of Flounder: a strawman device definition DSL for Barrelfish
-
+
Copyright (c) 2009, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
-}
-
+
module Parser where
import Syntax
-import Prelude
+import Prelude
import Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Pos
parse_include predefDecls filename = parseFromFile (includefile predefDecls) filename
lexer = P.makeTokenParser (javaStyle
- { P.reservedNames = [ "interface",
+ { P.reservedNames = [ "interface",
"message",
"rpc",
"in",
, P.commentEnd = "*/"
})
-whiteSpace = P.whiteSpace lexer
+whiteSpace = P.whiteSpace lexer
reserved = P.reserved lexer
identifier = P.identifier lexer
stringLit = P.stringLiteral lexer
builtinTypes = map show [UInt8 ..] ++ ["errval"] ++ ["int"] -- int is legacy -AB
-- identifyBuiltin :: [(String, Declaration)] -> String -> TypeRef
-identifyBuiltin typeDcls typeName =
+identifyBuiltin typeDcls typeName =
do {
if typeName `elem` builtinTypes then
return $ Builtin $ (read typeName::TypeBuiltin)
- else
+ else
case typeName `lookup` typeDcls of
Just (Typedef (TAliasT new orig)) -> return $ TypeAlias new orig
- Just _ -> return $ TypeVar typeName
- Nothing ->
+ Just _ -> return $ TypeVar typeName
+ Nothing ->
do {
; pos <- getPosition
-- This is ugly, I agree:
}
iface predefDecls = do { reserved "interface"
- ; name <- identifier
+ ; name <- identifier
; descr <- option name stringLit
; decls <- braces $ do {
; typeDecls <- typeDeclaration predefDecls
typeDeclaration typeDcls = do {
; decl <- try (do {
- ; x <- transparentAlias
+ ; x <- transparentAlias
; return $ Just x
})
<|> try (do {
; return $ Just x
})
<|> return Nothing
- ; case decl of
+ ; case decl of
Nothing -> return typeDcls
Just x -> typeDeclaration (x : typeDcls)
- }
+ }
mesg typeDcls = do { bckArgs <- many backendParams
; def <- msg typeDcls bckArgs <|> rpc typeDcls bckArgs
; return (Arg bType (DynamicArray n l))
}
-transparentAlias = do { whiteSpace
+transparentAlias = do { whiteSpace
; reserved "alias"
; newType <- identifier
; originType <- identifier
; symbol ";"
- ; return (newType, Typedef $ TAliasT newType
+ ; return (newType, Typedef $ TAliasT newType
(read originType::TypeBuiltin))
}
<|> try (array_typedef typeDcls)
<|> try enum_typedef
<|> (alias_typedef typeDcls)
-
+
struct_typedef typeDcls = do { reserved "struct"
; f <- braces $ many1 (struct_field typeDcls)
; i <- identifier
}
struct_field typeDcls = do { t <- identifier
- ; i <- identifier
+ ; i <- identifier
; symbol ";"
; b <- identifyBuiltin typeDcls t
; return (TStructField b i)
RPCClient.hs: Flounder stub generator for RPC client-side stubs
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module RPCClient where
------------------------------------------------------------------------
header :: String -> String -> Interface -> String
-header infile outfile intf =
+header infile outfile intf =
unlines $ C.pp_unit $ header_file intf (rpc_header_body infile intf)
where
header_file :: Interface -> [C.Unit] -> C.Unit
- header_file interface@(Interface name _ _) body =
+ header_file interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_RPC_CLIENT_H"
in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
rpcs = [m | m@(RPC _ _ _) <- messagedecls]
rpc_vtbl_decl :: String -> [MessageDef] -> C.Unit
-rpc_vtbl_decl n ml =
+rpc_vtbl_decl n ml =
C.StructDecl (rpc_vtbl_type n) [ intf_vtbl_param n m TX | m <- ml ]
rpc_binding_param :: String -> C.Param
C.Param (C.Struct "waitset_chanstate") "dummy_chanstate"]
rpc_init_fn_proto :: String -> C.Unit
-rpc_init_fn_proto n =
- C.GVarDecl C.Extern C.NonConst
+rpc_init_fn_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") (rpc_init_fn_params n)) name Nothing
- where
+ where
name = rpc_init_fn_name n
------------------------------------------------------------------------
C.Ex $ C.Assignment (rpc_rx_union_elem mn len) (C.Variable len)]
where
typespec = type_c_type ifn tr
- srcarg an =
+ srcarg an =
case lookup_typeref typedefs tr of
-- XXX: I have no idea why GCC requires a cast for the array type
TArray _ _ _ -> C.Cast (C.Ptr typespec) (C.Variable an)
%if false
Flounder2: an even more simpler IDL for Barrelfish
-
+
Copyright (c) 2009 ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
and, potentially, a @description@. It contains a list of
\emph{declarations}.
-> data Interface = Interface String (Maybe String) [ Declaration ]
+> data Interface = Interface String (Maybe String) [ Declaration ]
>
> generalInterface :: Maybe String -> String -> [ Declaration ] -> Interface
-> generalInterface description name declarations =
+> generalInterface description name declarations =
> Interface name description declarations
Which can be further refined into an anonymous interface, ie. with no
And, the more common, a documented interface:
> interface :: String -> String -> [Declaration] -> Interface
-> interface name description declarations =
+> interface name description declarations =
> generalInterface (Just description) name declarations
Finally, various getters:
> data TypeDef = TStruct String [StructField]
> | TArray TypeRef String Integer
-> | TEnum String [String]
+> | TEnum String [String]
> | TAlias String TypeRef
> | TAliasT String TypeBuiltin
> show ErrVal = "errval"
> instance Read TypeBuiltin where
-> readsPrec _ = \s -> case s of
+> readsPrec _ = \s -> case s of
> "uint8" -> [(UInt8, "")]
> "uint16" -> [(UInt16, "")]
> "uint32" -> [(UInt32, "")]
> | null $ tail defs = head defs
> | otherwise = error $ "lookup_type_name: " ++ name ++ " multiply defined"
> defs = [t | t <- types, typedef_name t == name]
->
+>
> typedef_name :: TypeDef -> String
> typedef_name (TStruct n _) = n
> typedef_name (TArray _ n _) = n
> data MessageDef = Message MessageType String [ MessageArgument ] [(String, [(String, MetaArgument)])]
> | RPC String [ RPCArgument ] [(String, [(String, MetaArgument)])]
>
-> data MessageType = MMessage
+> data MessageType = MMessage
> | MCall
> | MResponse
>
>
> argDynamic, (.#.) :: TypeRef -> (String, String) -> MessageArgument
> argDynamic typeArg (identifier, length) = Arg typeArg (DynamicArray identifier length)
-> (.#.) = argDynamic
+> (.#.) = argDynamic
And we are done for message definitions.
{-
THCBackend: generate interface to Flounder THC stubs
-
+
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module THCBackend where
rpc_argstruct_name :: String -> String -> String -> String
rpc_argstruct_name ifn n inout = idscope ifn n (inout ++ "_args_t")
-rpc_union_name :: String -> String -> String
+rpc_union_name :: String -> String -> String
rpc_union_name ifn n = idscope ifn n "_union_t"
-- Name of the enumeration of message numbers
-- Name of the struct type for the method vtable
intf_vtbl_type :: String -> String -> String -> String
-intf_vtbl_type ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv
+intf_vtbl_type ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv
intf_vtbl_type_x :: String -> String -> String -> String
intf_vtbl_type_x ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv ++ "_x"
unlines $ C.pp_unit $ intf_thc_header_file infile interface
intf_thc_header_file :: String -> Interface -> C.Unit
-intf_thc_header_file infile interface@(Interface name _ _) =
+intf_thc_header_file infile interface@(Interface name _ _) =
let sym = "__" ++ name ++ "_THC_IF_H"
in
C.IfNDef sym ([ C.Define sym [] "1"] ++ (intf_thc_header_body infile interface)) []
intf_thc_header_body :: String -> Interface -> [C.Unit]
-intf_thc_header_body infile interface@(Interface name descr decls) =
+intf_thc_header_body infile interface@(Interface name descr decls) =
let (types, messages) = partitionTypesMessages decls
in [ BC.intf_preamble infile name descr,
C.Blank,
C.TypeDef (C.Struct $ intf_bind_type name "client") (intf_bind_type name "client"),
C.TypeDef (C.Struct $ intf_bind_type name "service") (intf_bind_type name "service"),
-
+
C.Blank,
C.MultiComment [ "Struct type for holding the args for each msg" ],
C.UnitList [ msg_argstruct name m | m <- messages ],
C.MultiComment [ "Initialize a THC binding over an IDC binding",
"(defined in THC-stubs backend)" ],
C.Blank,
- C.GVarDecl C.Extern C.NonConst
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") [
C.Param (C.Ptr $ C.TypeName $ intf_bind_type name "client") "thc",
C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_c2s",
C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_s2c"
]) (init_client_name name) Nothing,
- C.GVarDecl C.Extern C.NonConst
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") [
C.Param (C.Ptr $ C.TypeName $ intf_bind_type name "service") "thc",
C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_c2s",
C.Param (C.TypeName "errval_t") "err",
C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name",
C.Param (C.TypeName "iref_t") "iref",
- C.Param (C.Ptr $ C.TypeName "iref_t") "iref_ptr"
+ C.Param (C.Ptr $ C.TypeName "iref_t") "iref_ptr"
],
C.StructDecl (thc_connect_info_struct_name name) [
C.Param (C.TypeName "thc_sem_t") "bind_cb_done_sem",
binding_struct :: Side -> String -> [MessageDef] -> C.Unit
binding_struct side ifn messages =
- let end = (case side of
- ClientSide -> "client"
+ let end = (case side of
+ ClientSide -> "client"
ServerSide -> "service")
nmessages = length messages
rpcparams ServerSide = []
params = [ C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn receiver) intf_bind_var,
C.Param (C.Ptr $ C.Struct $ rx_any_struct_name ifn receiver) "msg",
C.Param (C.Struct $ intf_selector_type ifn receiver) "ops" ]
- rx_t_name = rx_any_sig_type ifn receiver
- rx_t_name_x = rx_any_sig_type_x ifn receiver
+ rx_t_name = rx_any_sig_type ifn receiver
+ rx_t_name_x = rx_any_sig_type_x ifn receiver
in
C.UnitList [
- C.StructDecl (rx_any_struct_name ifn receiver)
+ C.StructDecl (rx_any_struct_name ifn receiver)
[ C.Param (C.Enum $ msg_enum_name ifn) "msg",
C.Param (C.Union $ binding_arg_union_type ifn ) "args"
],
call_signature :: String -> MessageDef -> C.Unit
call_signature ifname m@(RPC s args _) =
let name = call_sig_type ifname m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
call_signature_x :: String -> MessageDef -> C.Unit
call_signature_x ifname m@(RPC s args _) =
let name = call_sig_type_x ifname m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
call_ooo_signature :: String -> MessageDef -> C.Unit
call_ooo_signature ifname m@(RPC s args _) =
let name = call_ooo_sig_type ifname m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- (tail (tail args)) ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
call_ooo_signature_x :: String -> MessageDef -> C.Unit
call_ooo_signature_x ifname m@(RPC s args _) =
let name = call_ooo_sig_type_x ifname m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- (tail (tail args)) ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
send_signature side sender ifname m@(Message dir _ args _) =
let name = msg_sig_type ifname sender "send" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
+ intf_bind_var
params = [ binding ] ++ concat [ BC.msg_argdecl BC.TX ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
send_signature side sender ifname m@(RPC s args _) =
let name = msg_sig_type ifname sender "send" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_send_argdecl side ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
receive_signature side receiver ifname m@(Message dir _ args _) =
let name = msg_sig_type ifname receiver "recv" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
+ intf_bind_var
params = [ binding ] ++ concat [ receive_msg_argdecl ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
receive_signature side receiver ifname m@(RPC s args _) =
let name = msg_sig_type ifname receiver "recv" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_receive_argdecl side ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
send_signature_x side sender ifname m@(Message dir _ args _) =
let name = msg_sig_type_x ifname sender "send" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
+ intf_bind_var
params = [ binding ] ++ concat [ BC.msg_argdecl BC.TX ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
send_signature_x side sender ifname m@(RPC s args _) =
let name = msg_sig_type_x ifname sender "send" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_send_argdecl side ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
receive_signature_x side receiver ifname m@(Message dir _ args _) =
let name = msg_sig_type_x ifname receiver "recv" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
+ intf_bind_var
params = [ binding ] ++ concat [ receive_msg_argdecl ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
receive_signature_x side receiver ifname m@(RPC s args _) =
let name = msg_sig_type_x ifname receiver "recv" m
- binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
- intf_bind_var
+ binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
+ intf_bind_var
params = [ binding ] ++ concat [ rpc_receive_argdecl side ifname a | a <- args ]
in
C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
rpc_send_argdecl ServerSide ifn (RPCArgOut tr v) = BC.msg_argdecl BC.TX ifn (Arg tr v)
receive_msg_argdecl :: String -> MessageArgument -> [C.Param]
-receive_msg_argdecl ifn (Arg tr (Name n)) =
+receive_msg_argdecl ifn (Arg tr (Name n)) =
[ C.Param (C.Ptr $ BC.type_c_type ifn tr) n ]
-receive_msg_argdecl ifn (Arg tr (DynamicArray n l)) =
- [ C.Param (C.Ptr $ C.Ptr $ BC.type_c_type ifn tr) n,
+receive_msg_argdecl ifn (Arg tr (DynamicArray n l)) =
+ [ C.Param (C.Ptr $ C.Ptr $ BC.type_c_type ifn tr) n,
C.Param (C.Ptr $ BC.type_c_type ifn size) l ]
rpc_receive_argdecl :: Side -> String -> RPCArgument -> [C.Param]
rpc_receive_argdecl ServerSide ifn (RPCArgIn tr v) = receive_msg_argdecl ifn (Arg tr v)
msg_enums :: (String -> String) -> (String -> String -> String) -> String -> [MessageDef] -> C.Unit
-msg_enums enum element ifname msgs =
- C.EnumDecl (enum ifname)
- ([ C.EnumItem (element ifname n) Nothing
+msg_enums enum element ifname msgs =
+ C.EnumDecl (enum ifname)
+ ([ C.EnumItem (element ifname n) Nothing
| m@(Message _ n _ _) <- msgs ]
++
- [ C.EnumItem (element ifname n) Nothing
+ [ C.EnumItem (element ifname n) Nothing
| m@(RPC n _ _) <- msgs ]
)
--
-- Generate a struct to hold the arguments of a message while it's being sent.
---
+--
msg_argstruct :: String -> MessageDef -> C.Unit
msg_argstruct ifname m@(Message _ n [] _) = C.NoOp
msg_argstruct ifname m@(Message _ n args _) =
let tn = msg_argstruct_name ifname n
in
C.StructDecl tn (concat [ BC.msg_argdecl BC.RX ifname a | a <- args ])
-msg_argstruct ifname m@(RPC n args _) =
+msg_argstruct ifname m@(RPC n args _) =
C.UnitList [
- C.StructDecl (rpc_argstruct_name ifname n "in")
+ C.StructDecl (rpc_argstruct_name ifname n "in")
(concat [ rpc_argdecl ClientSide ifname a | a <- args ]),
- C.StructDecl (rpc_argstruct_name ifname n "out")
+ C.StructDecl (rpc_argstruct_name ifname n "out")
(concat [ rpc_argdecl ServerSide ifname a | a <- args ]),
C.UnionDecl (rpc_union_name ifname n) [
C.Param (C.Struct $ rpc_argstruct_name ifname n "in") "in",
--
-- Generate a union of all the above
---
+--
intf_union :: String -> [MessageDef] -> C.Unit
-intf_union ifn msgs =
+intf_union ifn msgs =
C.UnionDecl (binding_arg_union_type ifn)
([ C.Param (C.Struct $ msg_argstruct_name ifn n) n
| m@(Message _ n a _) <- msgs, 0 /= length a ]
++
- [ C.Param (C.Union $ rpc_union_name ifn n) n
+ [ C.Param (C.Union $ rpc_union_name ifn n) n
| m@(RPC n a _) <- msgs, 0 /= length a ])
rpc_argdecl :: Side -> String -> RPCArgument -> [C.Param]
{-
THCBackend: generate interface to Flounder THC stubs
-
+
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module THCStubsBackend where
-- Name of the concrete send/receive functions
send_fn_name :: Side -> String -> String -> String
-send_fn_name ClientSide ifn mn = idscope ifn ("client_" ++ mn) "send"
-send_fn_name ServerSide ifn mn = idscope ifn ("service_" ++ mn) "send"
+send_fn_name ClientSide ifn mn = idscope ifn ("client_" ++ mn) "send"
+send_fn_name ServerSide ifn mn = idscope ifn ("service_" ++ mn) "send"
send_fn_name_x :: Side -> String -> String -> String
-send_fn_name_x ClientSide ifn mn = idscope ifn ("client_" ++ mn) "send_x"
-send_fn_name_x ServerSide ifn mn = idscope ifn ("service_" ++ mn) "send_x"
+send_fn_name_x ClientSide ifn mn = idscope ifn ("client_" ++ mn) "send_x"
+send_fn_name_x ServerSide ifn mn = idscope ifn ("service_" ++ mn) "send_x"
bh_recv_fn_name :: Side -> String -> String -> String
-bh_recv_fn_name ClientSide ifn mn = idscope ifn ("client_" ++ mn) "bh_recv"
-bh_recv_fn_name ServerSide ifn mn = idscope ifn ("service_" ++ mn) "bh_recv"
+bh_recv_fn_name ClientSide ifn mn = idscope ifn ("client_" ++ mn) "bh_recv"
+bh_recv_fn_name ServerSide ifn mn = idscope ifn ("service_" ++ mn) "bh_recv"
recv_fn_name :: Side -> String -> String -> String
-recv_fn_name ClientSide ifn mn = idscope ifn ("client_" ++ mn) "recv"
-recv_fn_name ServerSide ifn mn = idscope ifn ("service_" ++ mn) "recv"
+recv_fn_name ClientSide ifn mn = idscope ifn ("client_" ++ mn) "recv"
+recv_fn_name ServerSide ifn mn = idscope ifn ("service_" ++ mn) "recv"
recv_fn_name_x :: Side -> String -> String -> String
-recv_fn_name_x ClientSide ifn mn = idscope ifn ("client_" ++ mn) "recv_x"
-recv_fn_name_x ServerSide ifn mn = idscope ifn ("service_" ++ mn) "recv_x"
+recv_fn_name_x ClientSide ifn mn = idscope ifn ("client_" ++ mn) "recv_x"
+recv_fn_name_x ServerSide ifn mn = idscope ifn ("service_" ++ mn) "recv_x"
-- Name of the funtcion to call to initialize client/service bindings
thc_init_bindings_name = "thc_init_binding_states"
ptr_rpc_argstruct_name :: String -> String -> String -> String
ptr_rpc_argstruct_name ifn n inout = idscope ifn n (inout ++ "_ptr_args_t")
-ptr_rpc_union_name :: String -> String -> String
+ptr_rpc_union_name :: String -> String -> String
ptr_rpc_union_name ifn n = idscope ifn n "_ptr_union_t"
-- Name of the struct type holding all the arguments for recv any
-- Names for the RPC layer functinos
call_seq_fn_name :: String -> String -> String
-call_seq_fn_name ifn mn = idscope ifn mn "call_seq"
+call_seq_fn_name ifn mn = idscope ifn mn "call_seq"
call_seq_fn_name_x :: String -> String -> String
-call_seq_fn_name_x ifn mn = idscope ifn mn "call_seq_x"
+call_seq_fn_name_x ifn mn = idscope ifn mn "call_seq_x"
call_fifo_fn_name :: String -> String -> String
-call_fifo_fn_name ifn mn = idscope ifn mn "call_fifo"
+call_fifo_fn_name ifn mn = idscope ifn mn "call_fifo"
call_fifo_fn_name_x :: String -> String -> String
-call_fifo_fn_name_x ifn mn = idscope ifn mn "call_fifo_x"
+call_fifo_fn_name_x ifn mn = idscope ifn mn "call_fifo_x"
call_ooo_fn_name :: String -> String -> String
-call_ooo_fn_name ifn mn = idscope ifn mn "call_ooo"
+call_ooo_fn_name ifn mn = idscope ifn mn "call_ooo"
call_ooo_fn_name_x :: String -> String -> String
-call_ooo_fn_name_x ifn mn = idscope ifn mn "call_ooo_x"
+call_ooo_fn_name_x ifn mn = idscope ifn mn "call_ooo_x"
data IDCChannel = C2S | S2C;
data Cancelable = CANCELABLE | NONCANCELABLE;
-select_idc :: Side -> BC.Direction -> IDCChannel
+select_idc :: Side -> BC.Direction -> IDCChannel
select_idc ClientSide BC.TX = C2S
select_idc ClientSide BC.RX = S2C
select_idc ServerSide BC.TX = S2C
unlines $ C.pp_unit $ C.UnitList $ intf_thc_stubs_file infile interface
intf_thc_stubs_file :: String -> Interface -> [ C.Unit ]
-intf_thc_stubs_file infile interface@(Interface name descr decls) =
+intf_thc_stubs_file infile interface@(Interface name descr decls) =
let (types, messages) = partitionTypesMessages decls
nmessages = length messages
- in [
+ in [
intf_thc_stubs_preamble infile name descr,
C.Blank,
C.Include C.Standard "stddef.h",
[ C.Include C.Local (name ++ "_thc.h"),
C.Include C.Local "thc.h" ],
C.Blank,
-
+
C.MultiComment [ "Send functions" ],
C.UnitList [ send_function NONCANCELABLE ClientSide name m | m <- messages, isForward m ],
C.UnitList [ send_function NONCANCELABLE ServerSide name m | m <- messages, isBackward m ],
bind_cb_function name,
connect_function name,
connect_by_name_function name,
-
+
C.Blank
]
intf_thc_stubs_preamble :: String -> String -> Maybe String -> C.Unit
-intf_thc_stubs_preamble infile name descr =
+intf_thc_stubs_preamble infile name descr =
let dstr = case descr of
Nothing -> "not specified"
Just s -> s
in
- C.MultiComment [
+ C.MultiComment [
"Copyright (c) 2010, ETH Zurich.",
"All rights reserved.",
"",
"THIS FILE IS AUTOMATICALLY GENERATED BY FLOUNDER: DO NOT EDIT!" ]
msg_argname :: MessageArgument -> [C.Expr]
-msg_argname (Arg tr (Name n)) =
+msg_argname (Arg tr (Name n)) =
[ C.Variable n ]
-msg_argname (Arg tr (DynamicArray n l)) =
+msg_argname (Arg tr (DynamicArray n l)) =
[ C.Variable n,
C.Variable l ]
startend_call :: String -> String -> String -> C.Stmt
startend_call fn ifn mn =
- C.Ex $ C.Call fn [
+ C.Ex $ C.Call fn [
C.Variable intf_bind_var
]
--- struct foo_binding *_idc_binding =
+-- struct foo_binding *_idc_binding =
-- (struct foo_binding *)((_thc_binding) -> st)
init_idc_binding_var :: IDCChannel -> String -> C.Stmt
init_idc_binding_var C2S ifn =
C.VarDecl C.NoScope C.NonConst idc_binding_type intf_c2s_idc_bind_var (Just initializer)
- where
+ where
idc_binding_type = C.Ptr $ C.Struct $ BC.intf_bind_type ifn
initializer = C.Cast (idc_binding_type) (C.DerefField (C.Variable intf_bind_var) "_c2s_st")
init_idc_binding_var S2C ifn =
C.VarDecl C.NoScope C.NonConst idc_binding_type intf_s2c_idc_bind_var (Just initializer)
- where
+ where
idc_binding_type = C.Ptr $ C.Struct $ BC.intf_bind_type ifn
initializer = C.Cast (idc_binding_type) (C.DerefField (C.Variable intf_bind_var) "_s2c_st")
init_thc_binding_var :: Side -> String -> C.Stmt
init_thc_binding_var side ifn =
C.VarDecl C.NoScope C.NonConst thc_binding_type intf_bind_var (Just initializer)
- where
+ where
thc_binding_type = C.Ptr $ C.Struct $ THC.intf_bind_type ifn (show side)
initializer = C.Cast (thc_binding_type) (C.DerefField (C.Variable intf_bh_idc_bind_var) "st")
-- }
bh_recv_function :: Side -> String -> MessageDef -> C.Unit
-bh_recv_function side ifn m@(Message _ n args _) =
+bh_recv_function side ifn m@(Message _ n args _) =
let pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
- perrx_ nm = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ nm)
+ perrx_ nm = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ nm)
perrx m@(Message _ n args _) = perrx_ $ recvEnum side ifn n
perrx m@(RPC n args _) = perrx_ $ recvEnum side ifn n
recvEnum ClientSide = THC.resp_msg_enum_elem_name
recvEnum ServerSide = THC.call_msg_enum_elem_name
common = C.Variable intf_bh_idc_bind_var
sidename = show side
- recv_function_args =
- concat [
- [C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type ifn) intf_bh_idc_bind_var],
+ recv_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type ifn) intf_bh_idc_bind_var],
(concat [ BC.msg_argdecl BC.RX ifn a | a <- args ]) ]
- decl_fn_var x =
+ decl_fn_var x =
C.VarDecl C.NoScope C.NonConst (C.Ptr $ C.Struct thc_receiver_info) "rxi" (Just x)
decl_args_var =
C.VarDecl C.NoScope C.NonConst (C.Ptr $ C.Struct $ ptr_binding_arg_struct_type ifn) "__attribute__((unused)) _args" (Just (C.DerefField (C.Variable "rxi") "args"))
assignment (Arg _ (DynamicArray an al)) =
[ C.Ex $ C.Assignment (C.DerefPtr ((C.FieldOf ((C.DerefField (C.Variable "_args") n)) an))) (C.Variable an),
C.Ex $ C.Assignment (C.DerefPtr ((C.FieldOf ((C.DerefField (C.Variable "_args") n)) al))) (C.Variable al) ]
- recv_function_body = [
+ recv_function_body = [
init_thc_binding_var side ifn,
decl_fn_var (C.Call thc_start_bh [ pb, common, ( perrx m ) ]),
C.If (C.Binary C.Equals (C.Variable "rxi") (C.Variable "NULL"))
++ concat [ assignment a | a <- args ]
++ [ C.Ex $ C.Call thc_end_bh [ pb, common, ( perrx m ), (C.Variable "rxi") ]
]
- in
- C.FunctionDef C.Static (C.Void) (bh_recv_fn_name side ifn n)
+ in
+ C.FunctionDef C.Static (C.Void) (bh_recv_fn_name side ifn n)
recv_function_args
recv_function_body;
-bh_recv_function side ifn m@(RPC n args _) =
+bh_recv_function side ifn m@(RPC n args _) =
let pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
- perrx_ nm = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ nm)
+ perrx_ nm = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ nm)
perrx m@(Message _ n args _) = perrx_ $ recvEnum side ifn n
perrx m@(RPC n args _) = perrx_ $ recvEnum side ifn n
recvEnum ClientSide = THC.resp_msg_enum_elem_name
recvEnum ServerSide = THC.call_msg_enum_elem_name
common = C.Variable intf_bh_idc_bind_var
sidename = show side
- recv_function_args =
- concat [
- [C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type ifn) intf_bh_idc_bind_var],
+ recv_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type ifn) intf_bh_idc_bind_var],
(concat [ rx_rpc_argdecl side ifn a | a <- args ]) ]
opname ClientSide n = n ++ "_response"
opname ServerSide n = n ++ "_call"
assignment (RPCArgOut _ (DynamicArray an al)) =
[ C.Ex $ C.Assignment (C.DerefPtr ((C.FieldOf (C.FieldOf ((C.DerefField (C.Variable "args") n)) "out" ) an))) (C.Variable an),
C.Ex $ C.Assignment (C.DerefPtr ((C.FieldOf (C.FieldOf ((C.DerefField (C.Variable "args") n)) "out" ) al))) (C.Variable al) ]
- decl_fn_var x =
+ decl_fn_var x =
C.VarDecl C.NoScope C.NonConst (C.Ptr $ C.Struct thc_receiver_info) "rxi" (Just x)
decl_args_var =
C.VarDecl C.NoScope C.NonConst (C.Ptr $ C.Struct $ ptr_binding_arg_struct_type ifn) "__attribute__((unused)) args" (Just (C.DerefField (C.Variable "rxi") "args"))
dir_args ServerSide = [ a | a@(RPCArgIn _ _) <- args ]
dir_args ClientSide = [ a | a@(RPCArgOut _ _) <- args ]
start_fn ClientSide m = if (THC.isOOORPC m) then thc_start_demuxable_bh else thc_start_bh
- start_fn ServerSide _ = thc_start_bh
+ start_fn ServerSide _ = thc_start_bh
demux_args ClientSide m = if (THC.isOOORPC m) then [ C.Variable "seq_out" ] else []
demux_args ServerSide _ = []
- recv_function_body = [
+ recv_function_body = [
init_thc_binding_var side ifn,
decl_fn_var (C.Call (start_fn side m) (concat [[ pb, common, ( perrx m ) ], (demux_args side m)])),
C.If (C.Binary C.Equals (C.Variable "rxi") (C.Variable "NULL"))
++ concat [ assignment a | a <- dir_args side ]
++ [C.Ex $ C.Call thc_end_bh [ pb, common, ( perrx m ), (C.Variable "rxi") ]
]
- in
- C.FunctionDef C.Static (C.Void) (bh_recv_fn_name side ifn n)
+ in
+ C.FunctionDef C.Static (C.Void) (bh_recv_fn_name side ifn n)
recv_function_args
recv_function_body;
--
--
-- static errval_t send_foo_t(struct ...binding_thc *thc,
--- uint64_t id,
--- uint64_t value1,
+-- uint64_t id,
+-- uint64_t value1,
-- uint64_t value2) {
-- ...binding b = (...) (thc->st);
-- do {
-- }
send_function :: Cancelable -> Side -> String -> MessageDef -> C.Unit
-send_function cb side ifn m@(Message _ n args _) =
+send_function cb side ifn m@(Message _ n args _) =
let fn_name CANCELABLE = send_fn_name_x side ifn n
fn_name NONCANCELABLE = send_fn_name side ifn n
sidename = show side
sem_p CANCELABLE = C.If (C.Binary C.Equals (C.Call "thc_sem_p_x" [ C.AddressOf $ C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_next_sender" ]) (C.Variable "THC_CANCELED")) [ C.Return $ C.Variable "THC_CANCELED" ] []
sem_p NONCANCELABLE = C.Ex $ C.Call "thc_sem_p" [ C.AddressOf $ C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_next_sender" ]
- await_send_branch CANCELABLE =
+ await_send_branch CANCELABLE =
[ C.If (C.Binary C.Equals (C.Call thc_await_send_fn_name_x [ C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name,
C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ]) (C.Variable "THC_CANCELED"))
[ C.Ex $ C.Call "thc_sem_v" [ C.AddressOf $ C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_next_sender" ],
C.Return $ C.Variable "THC_CANCELED" ] [ ] ]
- await_send_branch NONCANCELABLE =
+ await_send_branch NONCANCELABLE =
[ C.Ex $ C.Call thc_await_send_fn_name [ C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name,
- C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ] ]
- send_function_args =
- concat [
- [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
+ C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ] ]
+ send_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
(concat [ BC.msg_argdecl BC.TX ifn a | a <- args ]) ]
- send_function_body = [
+ send_function_body = [
init_idc_binding_var (select_idc side BC.TX) ifn,
sem_p cb,
C.Ex $ C.Assignment ( C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_send_complete" ) ( C.NumConstant 0 ),
C.DoWhile (C.NumConstant 1) [
C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_r"
(Just $ C.CallInd idc_tx_fn idc_tx_args),
- C.If (C.Binary C.Equals (C.Variable "_r") err_tx_busy_ex)
+ C.If (C.Binary C.Equals (C.Variable "_r") err_tx_busy_ex)
( await_send_branch cb )
[ C.Ex $ C.Call thc_complete_send_fn_name [ C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name,
C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ],
]
idc_binding = C.Variable (intf_idc_bind_var side BC.TX)
idc_tx_vtbl = C.DerefField idc_binding "tx_vtbl"
- idc_tx_fn = C.FieldOf idc_tx_vtbl n
+ idc_tx_fn = C.FieldOf idc_tx_vtbl n
idc_tx_args = [ idc_binding, send_cont_ex ]
++
(concat [ msg_argname a | a <- args])
- in
+ in
C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
send_function_args
send_function_body;
-send_function cb side ifn m@(RPC n args _) =
- let fn_name = (case cb of
+send_function cb side ifn m@(RPC n args _) =
+ let fn_name = (case cb of
CANCELABLE -> send_fn_name_x side ifn n
NONCANCELABLE -> send_fn_name side ifn n)
sidename = show side
sem_p CANCELABLE = C.If (C.Binary C.Equals (C.Call "thc_sem_p_x" [ C.AddressOf $ C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_next_sender" ]) (C.Variable "THC_CANCELED")) [ C.Return $ C.Variable "THC_CANCELED" ] []
sem_p NONCANCELABLE = C.Ex $ C.Call "thc_sem_p" [ C.AddressOf $ C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_next_sender" ]
- await_send_branch CANCELABLE =
+ await_send_branch CANCELABLE =
[ C.If (C.Binary C.Equals (C.Call thc_await_send_fn_name_x [ C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name,
C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ]) (C.Variable "THC_CANCELED"))
[ C.Ex $ C.Call "thc_sem_v" [ C.AddressOf $ C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_next_sender" ],
C.Return $ C.Variable "THC_CANCELED" ] [ ] ]
- await_send_branch NONCANCELABLE =
+ await_send_branch NONCANCELABLE =
[ C.Ex $ C.Call thc_await_send_fn_name [ C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name,
- C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ] ]
- send_function_args =
- concat [
- [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
+ C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ] ]
+ send_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
(concat [ rpc_argdecl BC.TX side ifn a | a <- args ]) ]
- send_function_body = [
+ send_function_body = [
init_idc_binding_var (select_idc side BC.TX) ifn,
sem_p cb,
C.Ex $ C.Assignment ( C.FieldOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name) "thc_send_complete" ) ( C.NumConstant 0 ),
C.DoWhile (C.NumConstant 1) [
C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_r"
(Just $ C.CallInd idc_tx_fn (idc_tx_args side)),
- C.If (C.Binary C.Equals (C.Variable "_r") err_tx_busy_ex)
+ C.If (C.Binary C.Equals (C.Variable "_r") err_tx_busy_ex)
( await_send_branch cb )
[ C.Ex $ C.Call thc_complete_send_fn_name [ C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name,
C.AddressOf $ C.DerefField (C.Variable (intf_idc_bind_var side BC.TX)) "st" ],
rpc_name ServerSide n = BC.rpc_resp_name n
idc_binding = C.Variable (intf_idc_bind_var side BC.TX)
idc_tx_vtbl = C.DerefField idc_binding "tx_vtbl"
- idc_tx_fn = C.FieldOf idc_tx_vtbl (rpc_name side n)
+ idc_tx_fn = C.FieldOf idc_tx_vtbl (rpc_name side n)
idc_tx_args ClientSide = idc_tx_args_in
idc_tx_args ServerSide = idc_tx_args_out
idc_tx_args_in = [ idc_binding, send_cont_ex ]
idc_tx_args_out = [ idc_binding, send_cont_ex ]
++
(concat [ rpc_argname ServerSide a | a <- args ])
- in
+ in
C.FunctionDef C.Static (C.TypeName "errval_t") fn_name
send_function_args
send_function_body;
C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn (show side)) intf_bind_var,
C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type ifn) intf_init_c2s_idc_bind_var,
C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type ifn) intf_init_s2c_idc_bind_var ]
- init_send_fn CANCELABLE m@(Message _ n args _) =
+ init_send_fn CANCELABLE m@(Message _ n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) (C.AddressOf $ C.Variable $ send_fn_name_x side ifn n)
- init_send_fn CANCELABLE m@(RPC n args _) =
+ init_send_fn CANCELABLE m@(RPC n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) (C.AddressOf $ C.Variable $ send_fn_name_x side ifn n)
- init_send_fn NONCANCELABLE m@(Message _ n args _) =
+ init_send_fn NONCANCELABLE m@(Message _ n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) (C.AddressOf $ C.Variable $ send_fn_name side ifn n)
- init_send_fn NONCANCELABLE m@(RPC n args _) =
+ init_send_fn NONCANCELABLE m@(RPC n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) (C.AddressOf $ C.Variable $ send_fn_name side ifn n)
init_recv_ n = C.Ex $ C.Call thc_init_per_recv_state [ C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ n) ]
init_recv m@(Message _ n args _) = init_recv_ $ recvEnum side ifn n
init_recv m@(RPC n args _) = init_recv_ $ recvEnum side ifn n
- init_bh m@(Message _ n args _) =
+ init_bh m@(Message _ n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable (intf_init_idc_bind_var side BC.RX)) "rx_vtbl") n) (C.AddressOf $ C.Variable $ bh_recv_fn_name side ifn n)
- init_bh m@(RPC n args _) =
+ init_bh m@(RPC n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable (intf_init_idc_bind_var side BC.RX)) "rx_vtbl") (opname side n)) (C.AddressOf $ C.Variable $ bh_recv_fn_name side ifn n)
- init_recv_fn NONCANCELABLE m@(Message _ n args _) =
+ init_recv_fn NONCANCELABLE m@(Message _ n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "recv") n) (C.AddressOf $ C.Variable $ recv_fn_name side ifn n)
- init_recv_fn NONCANCELABLE m@(RPC n args _) =
+ init_recv_fn NONCANCELABLE m@(RPC n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "recv") n) (C.AddressOf $ C.Variable $ recv_fn_name side ifn n)
- init_recv_fn CANCELABLE m@(Message _ n args _) =
+ init_recv_fn CANCELABLE m@(Message _ n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "recv_x") n) (C.AddressOf $ C.Variable $ recv_fn_name_x side ifn n)
- init_recv_fn CANCELABLE m@(RPC n args _) =
+ init_recv_fn CANCELABLE m@(RPC n args _) =
C.Ex $ C.Assignment (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "recv_x") n) (C.AddressOf $ C.Variable $ recv_fn_name_x side ifn n)
init_rpc_seq _ ServerSide _ = []
init_rpc_seq NONCANCELABLE ClientSide m@(RPC n _ _) =
check_field "change_waitset",
check_field "control",
check_field "error_handler",
- C.Ex $ C.Assignment (C.DerefField (C.Variable intf_bind_var) "_c2s_st") (C.Variable intf_init_c2s_idc_bind_var),
+ C.Ex $ C.Assignment (C.DerefField (C.Variable intf_bind_var) "_c2s_st") (C.Variable intf_init_c2s_idc_bind_var),
C.Ex $ C.Assignment (C.DerefField (C.Variable intf_bind_var) "_s2c_st") (C.Variable intf_init_s2c_idc_bind_var) ]
++ [ C.Ex $ C.Assignment ((C.DerefField (C.Variable intf_init_c2s_idc_bind_var)) "st") (C.Variable intf_bind_var) ]
++ [ C.Ex $ C.Assignment ((C.DerefField (C.Variable intf_init_s2c_idc_bind_var)) "st") (C.Variable intf_bind_var) ]
--
-- Generate a struct to hold the arguments of a message while it's being sent.
---
+--
msg_argstruct :: String -> MessageDef -> C.Unit
msg_argstruct ifname m@(Message _ n [] _) = C.NoOp
msg_argstruct ifname m@(Message _ n args _) =
let tn = ptr_msg_argstruct_name ifname n
in
C.StructDecl tn (concat [ ptr_msg_argdecl ifname a | a <- args ])
-msg_argstruct ifname m@(RPC n args _) =
+msg_argstruct ifname m@(RPC n args _) =
C.UnitList [
- C.StructDecl (ptr_rpc_argstruct_name ifname n "in")
+ C.StructDecl (ptr_rpc_argstruct_name ifname n "in")
(concat [ ptr_rpc_argdecl ClientSide ifname a | a <- args ]),
- C.StructDecl (ptr_rpc_argstruct_name ifname n "out")
+ C.StructDecl (ptr_rpc_argstruct_name ifname n "out")
(concat [ ptr_rpc_argdecl ServerSide ifname a | a <- args ]),
C.UnionDecl (ptr_rpc_union_name ifname n) [
C.Param (C.Struct $ ptr_rpc_argstruct_name ifname n "in") "in",
--
-- Generate a union of all the above
---
+--
intf_struct :: String -> [MessageDef] -> C.Unit
-intf_struct ifn msgs =
+intf_struct ifn msgs =
C.StructDecl (ptr_binding_arg_struct_type ifn)
([ C.Param (C.Struct $ ptr_msg_argstruct_name ifn n) n
| m@(Message _ n a _) <- msgs, 0 /= length a ]
++
- [ C.Param (C.Union $ ptr_rpc_union_name ifn n) n
+ [ C.Param (C.Union $ ptr_rpc_union_name ifn n) n
| m@(RPC n a _) <- msgs, 0 /= length a ])
ptr_msg_argdecl :: String -> MessageArgument -> [C.Param]
-ptr_msg_argdecl ifn (Arg tr (Name n)) =
+ptr_msg_argdecl ifn (Arg tr (Name n)) =
[ C.Param (C.Ptr $ BC.type_c_type ifn tr) n ]
-ptr_msg_argdecl ifn (Arg tr (DynamicArray n l)) =
- [ C.Param (C.Ptr $ C.Ptr $ BC.type_c_type ifn tr) n,
+ptr_msg_argdecl ifn (Arg tr (DynamicArray n l)) =
+ [ C.Param (C.Ptr $ C.Ptr $ BC.type_c_type ifn tr) n,
C.Param (C.Ptr $ BC.type_c_type ifn size) l ]
ptr_rpc_argdecl :: Side -> String -> RPCArgument -> [C.Param]
-- Generate recv functions
-recv_function_rpc_body assign cb side std_receive_fn ifn m@(RPC n args _) =
+recv_function_rpc_body assign cb side std_receive_fn ifn m@(RPC n args _) =
let pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
sidename = show side
recvEnum ClientSide = THC.resp_msg_enum_elem_name
C.Ex $ C.Assignment (((C.FieldOf (C.FieldOf (C.FieldOf (C.Variable "_args") n) "out") al))) (C.Variable al) ]
dir_args ServerSide = [ a | a@(RPCArgIn _ _) <- args ]
dir_args ClientSide = [ a | a@(RPCArgOut _ _) <- args ]
- in [
+ in [
C.VarDecl C.NoScope C.NonConst (C.Struct $ ptr_binding_arg_struct_type ifn) "_args" Nothing,
C.VarDecl C.NoScope C.NonConst (C.Struct thc_receiver_info) "_rxi" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "int") "_msg" Nothing ]
]
recv_function :: Cancelable -> Side -> String -> MessageDef -> C.Unit
-recv_function cb side ifn m@(Message _ n args _) =
+recv_function cb side ifn m@(Message _ n args _) =
let fn_name CANCELABLE = recv_fn_name_x side ifn n
fn_name NONCANCELABLE = recv_fn_name side ifn n
std_receive_fn_name CANCELABLE = receive_fn_name_x
sidename = show side
recvEnum ClientSide = THC.resp_msg_enum_elem_name
recvEnum ServerSide = THC.call_msg_enum_elem_name
- recv_function_args =
- concat [
- [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
+ recv_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
(concat [ THC.receive_msg_argdecl ifn a | a <- args ]) ]
assignment (Arg _ (Name an)) =
[ C.Ex $ C.Assignment (((C.FieldOf ((C.FieldOf (C.Variable "_args") n)) an))) (C.Variable an) ]
assignment (Arg _ (DynamicArray an al)) =
[ C.Ex $ C.Assignment (((C.FieldOf ((C.FieldOf (C.Variable "_args") n)) an))) (C.Variable an),
C.Ex $ C.Assignment (((C.FieldOf ((C.FieldOf (C.Variable "_args") n)) al))) (C.Variable al) ]
- recv_function_body = [
+ recv_function_body = [
C.VarDecl C.NoScope C.NonConst (C.Struct $ ptr_binding_arg_struct_type ifn) "_args" Nothing,
C.VarDecl C.NoScope C.NonConst (C.Struct thc_receiver_info) "_rxi" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "int") "_msg" Nothing ]
C.AddressOf $ C.Variable "_rxi"
]
]
- in
+ in
C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
recv_function_args
recv_function_body;
-recv_function cb side ifn m@(RPC n args _) =
+recv_function cb side ifn m@(RPC n args _) =
let fn_name CANCELABLE = recv_fn_name_x side ifn n
fn_name NONCANCELABLE = recv_fn_name side ifn n
std_receive_fn_name CANCELABLE = receive_fn_name_x
sidename = show side
recvEnum ClientSide = THC.resp_msg_enum_elem_name
recvEnum ServerSide = THC.call_msg_enum_elem_name
- recv_function_args =
- concat [
- [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
+ recv_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.Struct $ THC.intf_bind_type ifn sidename) intf_bind_var],
(concat [ receive_rpc_argdecl side ifn a | a <- args ]) ]
assignment (RPCArgIn _ (Name an)) =
[ C.Ex $ C.Assignment (((C.FieldOf (C.FieldOf (C.FieldOf (C.Variable "_args") n) "in") an))) (C.Variable an) ]
C.Ex $ C.Assignment (((C.FieldOf (C.FieldOf (C.FieldOf (C.Variable "_args") n) "out") al))) (C.Variable al) ]
dir_args ServerSide = [ a | a@(RPCArgIn _ _) <- args ]
dir_args ClientSide = [ a | a@(RPCArgOut _ _) <- args ]
- recv_function_body = [
+ recv_function_body = [
C.VarDecl C.NoScope C.NonConst (C.Struct $ ptr_binding_arg_struct_type ifn) "_args" Nothing,
C.VarDecl C.NoScope C.NonConst (C.Struct thc_receiver_info) "_rxi" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "int") "_msg" Nothing ]
C.AddressOf $ C.Variable "_rxi"
]
]
- in
+ in
C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
recv_function_args
([ C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_result" Nothing ] ++
C.Ex $ C.Call (receive_any_wait_fn_name) [ pb, C.AddressOf $ C.Variable "_rxi" ]
end = show side
pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
- interested m@(Message _ mn _ _) stmts =
+ interested m@(Message _ mn _ _) stmts =
C.If (C.Binary C.NotEquals (C.FieldOf (C.Variable "ops") mn) (C.NumConstant 0) ) stmts []
- interested m@(RPC mn _ _) stmts =
+ interested m@(RPC mn _ _) stmts =
C.If (C.Binary C.NotEquals (C.FieldOf (C.Variable "ops") mn) (C.NumConstant 0) ) stmts []
recvEnum ClientSide = THC.resp_msg_enum_elem_name
recvEnum ServerSide = THC.call_msg_enum_elem_name
receive_any_fn_args = [
C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn end) intf_bind_var,
C.Param (C.Ptr $ C.Struct $ THC.rx_any_struct_name ifn end) "msg",
- C.Param (C.Struct $ THC.intf_selector_type ifn end) "ops"
+ C.Param (C.Struct $ THC.intf_selector_type ifn end) "ops"
]
per_rx_state m@(RPC n args _) = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ recvEnum side ifn n)
per_rx_state m@(Message _ n args _) = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ recvEnum side ifn n)
-- RPC layer
-gen_call_seq cb ifn m@(RPC n args _) =
+gen_call_seq cb ifn m@(RPC n args _) =
let fn_name CANCELABLE = call_seq_fn_name_x ifn n
fn_name NONCANCELABLE = call_seq_fn_name ifn n
- call_function_args =
- concat [
- [C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn "client") intf_bind_var],
+ call_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn "client") intf_bind_var],
(concat [ call_rpc_argdecl ifn a | a <- args ]) ]
pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
call_function_body CANCELABLE = [
C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_result" Nothing,
- C.Ex $ C.Assignment (C.Variable "_result") (C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) $ concat [
+ C.Ex $ C.Assignment (C.Variable "_result") (C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) $ concat [
[ C.Variable intf_bind_var ],
concat [ send_arg a | a <- args ]
] ),
- C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
+ C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
[ C.Return (C.Variable "THC_CANCELED") ]
- ((recv_function_rpc_body "_result" cb ClientSide receive_fn_name_x ifn m) ++
- [ C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
- [ C.Ex $ C.Call "thc_discard" [
+ ((recv_function_rpc_body "_result" cb ClientSide receive_fn_name_x ifn m) ++
+ [ C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
+ [ C.Ex $ C.Call "thc_discard" [
pb,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
C.NumConstant 1 ] ]
C.Return $ C.Variable "_result" ])
]
- call_function_body NONCANCELABLE = [
- C.Ex $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) $ concat [
+ call_function_body NONCANCELABLE = [
+ C.Ex $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) $ concat [
[ C.Variable intf_bind_var ],
concat [ send_arg a | a <- args ]
],
receive_arg (RPCArgOut tr (Name an)) = [ C.Variable an ]
receive_arg (RPCArgOut tr (DynamicArray an al)) = [ C.Variable an, C.Variable al ]
receive_arg (RPCArgIn _ _ ) = [ ]
- in
- C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
+ in
+ C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
call_function_args
( call_function_body cb )
-gen_call_fifo cb ifn m@(RPC n args _) =
+gen_call_fifo cb ifn m@(RPC n args _) =
let fn_name CANCELABLE = call_fifo_fn_name_x ifn n
fn_name NONCANCELABLE = call_fifo_fn_name ifn n
- call_function_args =
- concat [
- [C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn "client") intf_bind_var],
+ call_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn "client") intf_bind_var],
(concat [ call_rpc_argdecl ifn a | a <- args ]) ]
pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
- perrx_ nm = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ nm)
+ perrx_ nm = C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ nm)
perrx m@(RPC n args _) = perrx_ $ recvEnum ClientSide ifn n
recvEnum ClientSide = THC.resp_msg_enum_elem_name
- call_function_body CANCELABLE = [
+ call_function_body CANCELABLE = [
C.VarDecl C.NoScope C.NonConst (C.TypeName "uint64_t") "_bailed" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_result" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "thc_queue_entry_t") "_q" Nothing,
C.Ex $ C.Call "thc_lock_acquire" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_lock" ],
- C.Ex $ C.Assignment (C.Variable "_result") $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) $ concat [
+ C.Ex $ C.Assignment (C.Variable "_result") $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) $ concat [
[ C.Variable intf_bind_var ],
concat [ send_arg a | a <- args ]
],
- C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
+ C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
[ C.Ex $ C.Call "thc_lock_release" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_lock" ],
C.Return (C.Variable "THC_CANCELED") ]
[ ],
C.Ex $ C.Call "thc_queue_enter" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_q", C.AddressOf $ C.Variable "_q" ],
C.Ex $ C.Call "thc_lock_release" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_lock" ],
C.Ex $ C.Assignment (C.Variable "_result") $ C.Call "thc_queue_await_turn_x" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_q", C.AddressOf $ C.Variable "_q" ],
- C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
+ C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
[ C.Ex $ C.Assignment (C.Variable "_bailed") $ C.Call "thc_queue_leave" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_q", C.AddressOf $ C.Variable "_q" ],
- C.Ex $ C.Call "thc_discard" [
+ C.Ex $ C.Call "thc_discard" [
pb,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
C.Variable "_bailed" ],
[ ]
] ++ (recv_function_rpc_body "_result" cb ClientSide receive_fn_name_x ifn m) ++ [
C.Ex $ C.Assignment (C.Variable "_bailed") $ C.Call "thc_queue_leave" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_q", C.AddressOf $ C.Variable "_q" ],
- C.Ex $ C.Call "thc_discard" [
+ C.Ex $ C.Call "thc_discard" [
pb,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
C.Variable "_bailed" ],
C.Return $ C.Variable "_result"
]
- call_function_body NONCANCELABLE = [
+ call_function_body NONCANCELABLE = [
C.VarDecl C.NoScope C.NonConst (C.TypeName "uint64_t") "_bailed" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_result" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "thc_queue_entry_t") "_q" Nothing,
C.Ex $ C.Call "thc_lock_acquire" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_lock" ],
- C.Ex $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) $ concat [
+ C.Ex $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) $ concat [
[ C.Variable intf_bind_var ],
concat [ send_arg a | a <- args ]
],
concat [ receive_arg a | a <- args ]
],
C.Ex $ C.Assignment (C.Variable "_bailed") $ C.Call "thc_queue_leave" [C.AddressOf $ C.DerefField (perrx m) "fifo_rpc_q", C.AddressOf $ C.Variable "_q" ],
- C.Ex $ C.Call "thc_discard" [
+ C.Ex $ C.Call "thc_discard" [
pb,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
C.Variable "_bailed" ],
receive_arg (RPCArgOut tr (Name an)) = [ C.Variable an ]
receive_arg (RPCArgOut tr (DynamicArray an al)) = [ C.Variable an, C.Variable al ]
receive_arg (RPCArgIn _ _ ) = [ ]
- in
- C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
+ in
+ C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
call_function_args
( call_function_body cb )
-gen_call_ooo cb ifn m@(RPC n (_:_:args) _) =
+gen_call_ooo cb ifn m@(RPC n (_:_:args) _) =
let fn_name CANCELABLE = call_ooo_fn_name_x ifn n
fn_name NONCANCELABLE = call_ooo_fn_name ifn n
pb = C.AddressOf $ C.DerefField (C.Variable intf_bind_var) THC.thc_per_binding_state_name
- call_function_args =
- concat [
- [C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn "client") intf_bind_var],
+ call_function_args =
+ concat [
+ [C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn "client") intf_bind_var],
(concat [ call_rpc_argdecl ifn a | a <- args ]) ]
assignment (RPCArgIn _ (Name an)) =
[ C.Ex $ C.Assignment (((C.FieldOf (C.FieldOf (C.FieldOf (C.Variable "_args") n) "in") an))) (C.Variable an) ]
assignment (RPCArgOut _ (DynamicArray an al)) =
[ C.Ex $ C.Assignment (((C.FieldOf (C.FieldOf (C.FieldOf (C.Variable "_args") n) "out") an))) (C.Variable an),
C.Ex $ C.Assignment (((C.FieldOf (C.FieldOf (C.FieldOf (C.Variable "_args") n) "out") al))) (C.Variable al) ]
- call_function_body CANCELABLE = [
+ call_function_body CANCELABLE = [
C.VarDecl C.NoScope C.NonConst (C.TypeName "errval_t") "_result" Nothing,
C.VarDecl C.NoScope C.NonConst (C.Struct $ ptr_binding_arg_struct_type ifn) "_args" Nothing,
C.VarDecl C.NoScope C.NonConst (C.Struct thc_receiver_info) "_rxi" Nothing,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
C.AddressOf $ C.Variable "_rxi"
],
- C.Ex $ C.Assignment (C.Variable "_result") $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) $ concat [
+ C.Ex $ C.Assignment (C.Variable "_result") $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send_x") n) $ concat [
[ C.Variable intf_bind_var,
C.Variable "_seq" ],
concat [ send_arg a | a <- args ]
],
- C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
+ C.If (C.Binary C.Equals (C.Variable "_result") (C.Variable "THC_CANCELED"))
[ C.Return $ C.Call cancel_receive_demux_fn_name [
pb,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
]
]
]
- call_function_body NONCANCELABLE = [
+ call_function_body NONCANCELABLE = [
C.VarDecl C.NoScope C.NonConst (C.Struct $ ptr_binding_arg_struct_type ifn) "_args" Nothing,
C.VarDecl C.NoScope C.NonConst (C.Struct thc_receiver_info) "_rxi" Nothing,
C.VarDecl C.NoScope C.NonConst (C.TypeName "int") "_msg" Nothing,
C.AddressOf $ C.SubscriptOf (C.DerefField (C.Variable intf_bind_var) THC.thc_per_recv_state_name) (C.Variable $ THC.resp_msg_enum_elem_name ifn n),
C.AddressOf $ C.Variable "_rxi"
],
- C.Ex $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) $ concat [
+ C.Ex $ C.CallInd (C.FieldOf (C.DerefField (C.Variable intf_bind_var) "send") n) $ concat [
[ C.Variable intf_bind_var,
C.Variable "_seq" ],
concat [ send_arg a | a <- args ]
receive_arg (RPCArgOut tr (Name an)) = [ C.Variable an ]
receive_arg (RPCArgOut tr (DynamicArray an al)) = [ C.Variable an, C.Variable al ]
receive_arg (RPCArgIn _ _ ) = [ ]
- in
- C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
+ in
+ C.FunctionDef C.Static (C.TypeName "errval_t") (fn_name cb)
call_function_args
(call_function_body cb)
--- static void ping_pong_thc_export_export_cb(void *st,
--- errval_t err,
+-- static void ping_pong_thc_export_export_cb(void *st,
+-- errval_t err,
-- iref_t iref) {
-- struct ping_pong_thc_export_info *info;
-- info = (struct ping_pong_thc_export_info*) st;
-- if (info->iref_ptr != NULL) {
-- *(info->iref_ptr) = iref;
-- }
--- }
+-- }
-- thc_sem_v(&info->export_cb_done_sem);
-- }
export_cb_function :: String -> C.Unit
export_cb_function ifn =
let info_ptr_t = C.Ptr $ THC.thc_export_info_t ifn
- info_err = C.DerefField (C.Variable "info") "err"
- info_service_name = C.DerefField (C.Variable "info") "service_name"
- info_iref_ptr = C.DerefField (C.Variable "info") "iref_ptr"
- ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
+ info_err = C.DerefField (C.Variable "info") "err"
+ info_service_name = C.DerefField (C.Variable "info") "service_name"
+ info_iref_ptr = C.DerefField (C.Variable "info") "iref_ptr"
+ ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
var_st = C.Variable "st"
var_err = C.Variable "err"
var_iref = C.Variable "iref"
connect_cb_function :: String -> C.Unit
connect_cb_function ifn =
let info_ptr_t = C.Ptr $ THC.thc_export_info_t ifn
- info_b = C.DerefField (C.Variable "info") "b"
- ptr_info_accept_call_present_sem = C.AddressOf $ C.DerefField (C.Variable "info") "accept_call_present_sem"
- ptr_info_connect_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "connect_cb_done_sem"
- ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
+ info_b = C.DerefField (C.Variable "info") "b"
+ ptr_info_accept_call_present_sem = C.AddressOf $ C.DerefField (C.Variable "info") "accept_call_present_sem"
+ ptr_info_connect_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "connect_cb_done_sem"
+ ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
var_st = C.Variable "st"
var_b = C.Variable "b"
in
-- idc_export_flags_t flags,
-- iref_t iref_ptr) {
-- errval_t err;
---
+--
-- thc_sem_init(&info->export_cb_done_sem, 0);
-- thc_sem_init(&info->connect_cb_done_sem, 0);
-- thc_sem_init(&info->accept_call_present_sem, 0);
-- err = info->err;
-- thc_lock_release(&info->info_lock);
-- }
---
+--
-- return err;
-- }
export_function :: String -> C.Unit
export_function ifn =
let info_ptr_t = C.Ptr $ THC.thc_export_info_t ifn
- info_service_name = C.DerefField (C.Variable "info") "service_name"
- info_err = C.DerefField (C.Variable "info") "err"
- info_iref_ptr = C.DerefField (C.Variable "info") "iref_ptr"
- ptr_info_export_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "export_cb_done_sem"
- ptr_info_connect_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "connect_cb_done_sem"
- ptr_info_accept_call_present_sem = C.AddressOf $ C.DerefField (C.Variable "info") "accept_call_present_sem"
- ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
- ptr_info_next_accept_lock = C.AddressOf $ C.DerefField (C.Variable "info") "next_accept_lock"
+ info_service_name = C.DerefField (C.Variable "info") "service_name"
+ info_err = C.DerefField (C.Variable "info") "err"
+ info_iref_ptr = C.DerefField (C.Variable "info") "iref_ptr"
+ ptr_info_export_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "export_cb_done_sem"
+ ptr_info_connect_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "connect_cb_done_sem"
+ ptr_info_accept_call_present_sem = C.AddressOf $ C.DerefField (C.Variable "info") "accept_call_present_sem"
+ ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
+ ptr_info_next_accept_lock = C.AddressOf $ C.DerefField (C.Variable "info") "next_accept_lock"
var_err = C.Variable "err"
var_info = C.Variable "info"
var_ws = C.Variable "ws"
C.Ex $ C.Assignment info_service_name var_service_name,
C.Ex $ C.Assignment info_err (C.Variable "SYS_ERR_OK"),
C.Ex $ C.Assignment info_iref_ptr var_iref_ptr,
- C.Ex $ C.Assignment var_err (C.Call (ifn ++ "_export")
+ C.Ex $ C.Assignment var_err (C.Call (ifn ++ "_export")
[ var_info,
C.Variable $ ifscope ifn "thc_export_cb",
C.Variable $ ifscope ifn "thc_connect_cb",
-- errval_t ping_pong_thc_accept(struct ping_pong_thc_export_info *info,
-- struct ping_pong_binding **b) {
-- struct ping_pong_binding *priv_b;
---
+--
-- // Wait to be the next accepter
-- thc_lock_acquire(&info->next_accept_lock);
-- info->b = &priv_b;
---
+--
-- // Signal to the bottom half that we are present
-- thc_sem_v(&info->accept_call_present_sem);
---
+--
-- // Wait for the bottom half to fill in the results
-- thc_sem_p(&info->connect_cb_done_sem);
-- errval_t err = info->err;
-- thc_lock_release(&info->info_lock);
-- thc_lock_release(&info->next_accept_lock);
---
+--
-- if (err_is_ok(err)) {
-- if (b != NULL) {
-- *b = priv_b;
-- }
-- }
---
+--
-- return err;
-- }
---
+--
accept_function :: String -> C.Unit
accept_function ifn =
- let info_service_name = C.DerefField (C.Variable "info") "service_name"
- info_err = C.DerefField (C.Variable "info") "err"
- info_b = C.DerefField (C.Variable "info") "b"
- ptr_info_export_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "export_cb_done_sem"
- ptr_info_connect_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "connect_cb_done_sem"
- ptr_info_accept_call_present_sem = C.AddressOf $ C.DerefField (C.Variable "info") "accept_call_present_sem"
- ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
- ptr_info_next_accept_lock = C.AddressOf $ C.DerefField (C.Variable "info") "next_accept_lock"
+ let info_service_name = C.DerefField (C.Variable "info") "service_name"
+ info_err = C.DerefField (C.Variable "info") "err"
+ info_b = C.DerefField (C.Variable "info") "b"
+ ptr_info_export_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "export_cb_done_sem"
+ ptr_info_connect_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "connect_cb_done_sem"
+ ptr_info_accept_call_present_sem = C.AddressOf $ C.DerefField (C.Variable "info") "accept_call_present_sem"
+ ptr_info_info_lock = C.AddressOf $ C.DerefField (C.Variable "info") "info_lock"
+ ptr_info_next_accept_lock = C.AddressOf $ C.DerefField (C.Variable "info") "next_accept_lock"
var_priv_b = C.Variable "priv_b"
var_err = C.Variable "err"
var_b = C.Variable "b"
bind_cb_function :: String -> C.Unit
bind_cb_function ifn =
let info_ptr_t = C.Ptr $ THC.thc_connect_info_t ifn
- info_err = C.DerefField (C.Variable "info") "err"
- info_b = C.DerefField (C.Variable "info") "b"
- ptr_info_bind_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "bind_cb_done_sem"
+ info_err = C.DerefField (C.Variable "info") "err"
+ info_b = C.DerefField (C.Variable "info") "b"
+ ptr_info_bind_cb_done_sem = C.AddressOf $ C.DerefField (C.Variable "info") "bind_cb_done_sem"
var_st = C.Variable "st"
var_err = C.Variable "err"
var_b = C.Variable "b"
-- info.b = NULL;
-- err = nameservice_blocking_lookup(service_name, &iref);
-- if (err_is_ok(err)) {
--- err = ping_pong_bind(iref,
+-- err = ping_pong_bind(iref,
-- ping_pong_thc_bind_cb,
-- &info,
-- ws,
C.VarDecl C.NoScope C.NonConst (C.TypeName "iref_t") "iref" Nothing,
-- Name service lookup
C.Ex $ C.Assignment var_err
- (C.Call "nameservice_blocking_lookup"
+ (C.Call "nameservice_blocking_lookup"
[ var_service_name, ptr_iref ]),
C.If (C.Call "err_is_ok" [ var_err ] )
[ -- Name service lookup OK
var_iref = C.Variable "iref"
var_info = C.Variable "info"
var_cl = C.Variable "cl"
- ptr_info_bind_cb_done_sem = C.AddressOf $ C.FieldOf (C.Variable "info") "bind_cb_done_sem"
+ ptr_info_bind_cb_done_sem = C.AddressOf $ C.FieldOf (C.Variable "info") "bind_cb_done_sem"
ptr_info = C.AddressOf var_info
- info_err = C.FieldOf (C.Variable "info") "err"
- info_b = C.FieldOf (C.Variable "info") "b"
+ info_err = C.FieldOf (C.Variable "info") "err"
+ info_b = C.FieldOf (C.Variable "info") "b"
in
C.FunctionDef C.NoScope (C.TypeName "errval_t") (THC.thc_connect_fn_name ifn)
[ C.Param (C.TypeName "iref_t") "iref",
UMP.hs: Flounder stub generator for cross-core shared memory message passing.
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module UMP where
[C.AddressOf $ my_bindvar `C.DerefField` "ump_state" `C.FieldOf` "chan"]]
init_fn_proto :: UMPParams -> String -> C.Unit
-init_fn_proto p n =
- C.GVarDecl C.Extern C.NonConst
+init_fn_proto p n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") (init_params p n)) name Nothing
- where
+ where
name = init_fn_name p n
init_params p n = [
UMPCommon.hs: Flounder stub generator for cross-core shared memory message passing.
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module UMPCommon where
------------------------------------------------------------------------
header :: UMPParams -> String -> String -> Interface -> String
-header p infile outfile intf =
+header p infile outfile intf =
unlines $ C.pp_unit $ header_file intf (header_body p infile intf)
where
header_file :: Interface -> [C.Unit] -> C.Unit
- header_file interface@(Interface name _ _) body =
+ header_file interface@(Interface name _ _) body =
let sym = "__" ++ name ++ "_" ++ (map toUpper (ump_drv p)) ++ "_H"
in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
connect_function_proto :: UMPParams -> String -> C.Unit
-connect_function_proto p n =
- C.GVarDecl C.Extern C.NonConst
+connect_function_proto p n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = connect_fn_name p n
params = connect_params p n
C.Param (C.TypeName "idc_bind_flags_t") "flags" ]
accept_function_proto :: UMPParams -> String -> C.Unit
-accept_function_proto p n =
- C.GVarDecl C.Extern C.NonConst
+accept_function_proto p n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = accept_fn_name p n
params = accept_params p n
destroy_function_proto :: UMPParams -> String -> C.Unit
-destroy_function_proto p n =
- C.GVarDecl C.Extern C.NonConst
+destroy_function_proto p n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope C.Void params) name Nothing
- where
+ where
name = destroy_fn_name p n
params = [C.Param (C.Ptr $ C.Struct (my_bind_type p n)) "b"]
bind_function_proto :: UMPParams -> String -> C.Unit
-bind_function_proto p n =
- C.GVarDecl C.Extern C.NonConst
+bind_function_proto p n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
- where
+ where
name = bind_fn_name p n
params = bind_params p n
C.Ex $ C.Assignment (common_field "control") (C.Variable $ generic_control_fn_name (ump_drv p) ifn),
C.Ex $ C.Assignment (common_field "st") (C.Variable "st"),
C.Ex $ C.Assignment (intf_bind_v `C.FieldOf` "bind_cont") (C.Variable intf_cont_var),
-
+
C.Ex $ C.Assignment errvar $ C.Call "ump_chan_init"
[C.AddressOf $ statevar `C.FieldOf` "chan",
(C.DerefField (C.Variable intf_frameinfo_var) "inbuf"),
C.Call "err_push" [errvar, C.Variable "LIB_ERR_UMP_CHAN_INIT"]]
[],
C.SBlank,
-
+
C.Ex $ C.Assignment (sendvar) (C.DerefField (C.Variable "_frameinfo") "sendbase"),
C.Ex $ C.Assignment (my_bindvar `C.DerefField` "inchanlen") (C.DerefField (C.Variable intf_frameinfo_var) "inbufsize"),
C.Ex $ C.Assignment (my_bindvar `C.DerefField` "outchanlen") (C.DerefField (C.Variable intf_frameinfo_var) "outbufsize"),
C.StmtList $ ump_store_notify_cap p ifn (C.Variable "notify_cap"),
C.StmtList $ setup_cap_handlers p ifn,
C.SBlank,
-
+
C.StmtList $ register_recv p ifn,
C.SBlank,
C.Return $ C.Call (tx_bind_msg_fn_name p ifn) [my_bindvar]]
- where
+ where
params = connect_params p ifn
errvar = C.Variable "err"
statevar = C.DerefField my_bindvar "ump_state"
C.SBlank,
C.Return (C.Variable "SYS_ERR_OK")]
- where
+ where
params = accept_params p ifn
statevar = C.DerefField my_bindvar "ump_state"
chanvar = statevar `C.FieldOf` "chan"
C.Ex $ C.CallInd (bindvar `C.DerefField` "bind_cont")
[bindvar `C.DerefField` "st", errvar, bindvar]]
- where
+ where
params = [C.Param (C.Ptr C.Void) "st",
C.Param (C.TypeName "errval_t") "err",
C.Param (C.Ptr $ C.Struct "ump_chan") "chan",
C.If (C.Binary C.Equals my_bindvar (C.Variable "NULL"))
[C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [],
C.SBlank,
-
+
localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
intf_bind_var (Just $ C.AddressOf $ my_bindvar `C.DerefField` "b"),
C.StmtList common_init,
common_field f = my_bindvar `C.DerefField` "b" `C.FieldOf` f
change_waitset_fn_def :: UMPParams -> String -> C.Unit
-change_waitset_fn_def p ifn =
+change_waitset_fn_def p ifn =
C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name p ifn) params [
localvar (C.Ptr $ C.Struct $ my_bind_type p ifn)
my_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar),
C.SBlank]
tx_cap_handler :: UMPParams -> String -> [MsgSpec] -> C.Unit
-tx_cap_handler p ifn msgspecs =
+tx_cap_handler p ifn msgspecs =
C.FunctionDef C.Static C.Void (tx_cap_handler_name p ifn) [C.Param (C.Ptr C.Void) "arg"] [
handler_preamble p ifn,
capst = umpst `C.FieldOf` "capst"
chan = umpst `C.FieldOf` "chan"
cases = [C.Case (C.NumConstant $ toInteger i) $ subcase cap i
- | (cap, i) <- zip caps [0..]] ++
+ | (cap, i) <- zip caps [0..]] ++
[C.Case (C.NumConstant $ toInteger $ length caps) last_case]
last_case = [
C.Ex $ C.Assignment msgheader ctrlvar,
C.StmtList finished_send,
C.Return (C.Variable "SYS_ERR_OK")]
- where
+ where
params = [C.Param (C.Ptr C.Void) "arg"]
chanst = C.AddressOf umpst
- chanaddr = C.AddressOf (C.DerefField chanst "chan")
+ chanaddr = C.AddressOf (C.DerefField chanst "chan")
ctrlvar = C.Variable "ctrl"
ctrladdr = C.AddressOf ctrlvar
umpst = C.DerefField my_bindvar "ump_state"
msgvar = C.Variable "msg"
msgword n = C.DerefField msgvar "data" `C.SubscriptOf` (C.NumConstant $ toInteger n)
msgheader = C.DerefField msgvar "header" `C.FieldOf` "control"
-
+
tx_bind_reply :: UMPParams -> String -> C.Unit
C.Ex $ C.Assignment msgheader ctrlvar,
C.StmtList finished_send,
C.Return (C.Variable "SYS_ERR_OK")]
- where
+ where
params = [C.Param (C.Ptr C.Void) "arg"]
chanst = C.AddressOf umpst
- chanaddr = C.AddressOf (C.DerefField chanst "chan")
+ chanaddr = C.AddressOf (C.DerefField chanst "chan")
umpst = C.DerefField my_bindvar "ump_state"
ctrlvar = C.Variable "ctrl"
ctrladdr = C.AddressOf ctrlvar
-- stateaddr = C.AddressOf umpst
msgvar = C.Variable "msg"
msgword n = C.DerefField msgvar "data" `C.SubscriptOf` (C.NumConstant $ toInteger n)
- msgheader = C.DerefField msgvar "header" `C.FieldOf` "control"
+ msgheader = C.DerefField msgvar "header" `C.FieldOf` "control"
tx_handler :: UMPParams -> String -> [MsgSpec] -> C.Unit
tx_handler p ifn msgs =
[C.Case (C.Variable $ msg_enum_elem_name ifn mn)
$ gen_msgcase mn msgfrags caps
| MsgSpec mn msgfrags caps <- msgs]
-
+
gen_msgcase mn msgfrags caps = [
C.SComment "Switch on current outgoing message fragment",
C.Switch (C.DerefField bindvar "tx_msg_fragment") fragcases
finished_send []
else C.StmtList finished_send,
C.ReturnVoid]
-
+
| otherwise = -- more fragments to go
[inc_fragnum, C.SComment "fall through to next fragment"]
[C.Case (C.NumConstant $ toInteger i) $
(if i == 0 then
-- first fragment of a message
- start_recv (ump_drv p) ifn typedefs mn msgargs ++
+ start_recv (ump_drv p) ifn typedefs mn msgargs ++
(if caps /= [] then [
-- + with caps received
C.Ex $ C.Assignment
(capst `C.FieldOf` "tx_cap_ack") (C.Variable "true"),
C.Ex $ C.Assignment
(capst `C.FieldOf` "rx_capnum") (C.NumConstant 0)
- ] else [])
+ ] else [])
else []) ++
(msgfrag_case msgdef frag caps (i == length frags - 1))
| (frag, i) <- zip frags [0..] ]
UMP_IPI.hs: Flounder stub generator for cross-core message passing using IPIs.
Part of Flounder: a message passing IDL for Barrelfish
-
+
Copyright (c) 2007-2010, ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
--}
+-}
module UMP_IPI where
intf_bind_var = C.DerefField my_bindvar "b"
accept_alloc_notify_cont_fn :: String -> C.Unit
-accept_alloc_notify_cont_fn ifn =
+accept_alloc_notify_cont_fn ifn =
C.FunctionDef C.Static C.Void (accept_alloc_notify_cont_name ifn) params [
localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
intf_bind_var (Just $ C.Variable "st"),
bind_alloc_notify_cont_fn :: String -> C.Unit
-bind_alloc_notify_cont_fn ifn =
+bind_alloc_notify_cont_fn ifn =
C.FunctionDef C.Static C.Void (bind_alloc_notify_cont_name ifn) params [
localvar (C.Ptr $ C.Struct $ intf_bind_type ifn)
intf_bind_var (Just $ C.Variable "st"),
init_fn_proto :: String -> C.Unit
-init_fn_proto n =
- C.GVarDecl C.Extern C.NonConst
+init_fn_proto n =
+ C.GVarDecl C.Extern C.NonConst
(C.Function C.NoScope (C.TypeName "errval_t") (init_params n)) name Nothing
- where
+ where
name = init_fn_name n
init_params n = [
%if false
Flounder2: an even more simpler IDL for Barrelfish
-
+
Copyright (c) 2009 ETH Zurich.
All rights reserved.
-
+
This file is distributed under the terms in the attached LICENSE file.
If you do not find this file, copies can be found by writing to:
ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
projects / barrelfish / commitdiff