git.barrelfish.org Git - barrelfish/blob - tools/flounder/BackendCommon.hs

   1 {-
   2    BackendCommon: Common code used by most backends
   3
   4   Part of Flounder: a message passing IDL for Barrelfish
   5
   6   Copyright (c) 2007-2010, ETH Zurich.
   7   All rights reserved.
   8
   9   This file is distributed under the terms in the attached LICENSE file.
  10   If you do not find this file, copies can be found by writing to:
  11   ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
  12 -}
  13
  14 module BackendCommon where
  15
  16 import qualified CAbsSyntax as C
  17 import Syntax
  18
  19 data Direction = TX | RX
  20     deriving (Show, Eq)
  21
  22 ------------------------------------------------------------------------
  23 -- Language mapping: C identifier names
  24 ------------------------------------------------------------------------
  25
  26 -- Scope a list of strings
  27 ifscope :: String -> String -> String
  28 --ifscope ifn s = ifn ++ "$" ++ s
  29 ifscope ifn s = ifn ++ "_" ++ s
  30
  31 idscope :: String -> String -> String -> String
  32 idscope ifn s suffix  = ifscope ifn (s ++ "__" ++ suffix)
  33
  34 drvscope :: String -> String -> String -> String
  35 drvscope drv ifn s = ifscope ifn (drv ++ "_" ++ s)
  36
  37 -- Name of the binding struct for an interface type
  38 intf_bind_type :: String -> String
  39 intf_bind_type ifn = ifscope ifn "binding"
  40
  41 -- Variable used to refer to a binding
  42 intf_bind_var = "_binding"
  43
  44 -- Name of the binding struct for an interface type
  45 intf_frameinfo_type :: String -> String
  46 intf_frameinfo_type ifn = ifscope ifn "frameinfo"
  47
  48 -- Variable used to refer to a continuation
  49 intf_frameinfo_var = "_frameinfo"
  50
  51 -- name of the maximum message size define
  52 msg_arg_size_name :: String -> String
  53 msg_arg_size_name ifname = ifscope ifname "_MAX_MESSAGE_SIZE"
  54
  55 arg_size_name :: String -> String -> String -> String
  56 arg_size_name ifname fname argn= ifscope ifname ("_" ++ fname ++ "_" ++ argn ++ "_MAX_ARGUMENT_SIZE")
  57
  58 -- Name of the bind continuation function type for an interface type
  59 intf_bind_cont_type :: String -> String
  60 intf_bind_cont_type ifn = ifscope ifn "bind_continuation_fn"
  61
  62 -- Variable used to refer to a continuation
  63 intf_cont_var = "_continuation"
  64
  65 -- name of the export state struct
  66 export_type n = ifscope n "export"
  67
  68 -- Name of the enumeration of message numbers
  69 msg_enum_name :: String -> String
  70 msg_enum_name ifn = ifscope ifn "msg_enum"
  71
  72 -- Name of each element of the message number enumeration
  73 msg_enum_elem_name :: String -> String -> String
  74 msg_enum_elem_name ifn mn = idscope ifn mn "msgnum"
  75
  76 -- Name of the type of a message function
  77 msg_sig_type :: String -> MessageDef -> Direction -> String
  78 msg_sig_type ifn m@(RPC _ _ _) _ = idscope ifn (msg_name m) "rpc_method_fn"
  79 msg_sig_type ifn m TX = idscope ifn (msg_name m) "tx_method_fn"
  80 msg_sig_type ifn m RX =  idscope ifn (msg_name m) "rx_method_fn"
  81
  82 msg_sig_type_rpc_rx :: String -> MessageDef -> String
  83 msg_sig_type_rpc_rx ifn m@(RPC _ _ _) = idscope ifn (msg_name m) "rpc_rx_method_fn"
  84
  85 -- Name of a given message definition
  86 msg_name :: MessageDef -> String
  87 msg_name (Message _ n _ _) = n
  88 msg_name (RPC n _ _) = n
  89
  90 -- Name of the static inline wrapper for sending messages
  91 tx_wrapper_name :: String -> String -> String
  92 tx_wrapper_name ifn mn = idscope ifn mn "tx"
  93
  94 -- Names of the underlying messages that are constructed from an RPC
  95 rpc_call_name n = n ++ "_call"
  96 rpc_resp_name n = n ++ "_response"
  97
  98 -- Name of the struct holding message args for SAR
  99 msg_argstruct_name :: Direction -> String -> String -> String
 100 msg_argstruct_name TX ifn n = idscope ifn n "tx_args"
 101 msg_argstruct_name RX ifn n = idscope ifn n "rx_args"
 102
 103 -- Name of the union type holding all the arguments for a message
 104 binding_arg_union_type :: Direction -> String -> String
 105 binding_arg_union_type TX ifn = ifscope ifn "tx_arg_union"
 106 binding_arg_union_type RX ifn = ifscope ifn "rx_arg_union"
 107
 108 -- Name of the C type for a concrete flounder type, struct, or enum
 109 type_c_struct, type_c_enum :: String -> String -> String
 110 type_c_struct ifn n = "_" ++ idscope ifn n "struct"
 111 type_c_enum ifn e = ifscope ifn e
 112
 113 type_c_name :: String -> TypeRef -> String
 114 type_c_name ifn (Builtin Cap) = undefined
 115 type_c_name ifn (Builtin GiveAwayCap) = undefined
 116 type_c_name ifn (Builtin String) = undefined
 117 type_c_name ifn (Builtin t) = (show t) ++ "_t"
 118 type_c_name ifn (TypeVar t) = type_c_name1 ifn t
 119 type_c_name ifn (TypeAlias t _) = type_c_name1 ifn t
 120
 121 type_c_name1 :: String -> String -> String
 122 type_c_name1 ifn tn = (ifscope ifn tn) ++ "_t"
 123
 124 type_c_type :: String -> TypeRef -> C.TypeSpec
 125 type_c_type ifn (Builtin Cap) = C.Struct "capref"
 126 type_c_type ifn (Builtin GiveAwayCap) = C.Struct "capref"
 127 type_c_type ifn (Builtin Char) = C.TypeName "char"
 128 type_c_type ifn (Builtin Bool) = C.TypeName "bool"
 129 type_c_type ifn (Builtin String) = C.Ptr $ C.TypeName "char"
 130 type_c_type ifn t = C.TypeName $ type_c_name ifn t
 131
 132 -- TX pointers should be const
 133 type_c_type_dir :: Direction -> String -> TypeRef -> C.TypeSpec
 134 type_c_type_dir TX ifn tr = case type_c_type ifn tr of
 135     C.Ptr t -> C.Ptr $ C.ConstT t
 136     t -> t
 137 type_c_type_dir RX ifn tr = type_c_type ifn tr
 138
 139 -- Array types in the msg args struct should only be pointers to the storage
 140 type_c_type_msgstruct :: Direction -> String -> [TypeDef] -> TypeRef -> C.TypeSpec
 141 type_c_type_msgstruct TX ifn typedefs t
 142     = case lookup_typeref typedefs t of
 143         TArray tr n _ -> C.Ptr $ type_c_type ifn t
 144         _ -> type_c_type ifn t
 145 type_c_type_msgstruct RX ifn typedefs t
 146     = case lookup_typeref typedefs t of
 147         _ -> type_c_type ifn t
 148
 149 -- Name of the struct type for the method vtable
 150 intf_vtbl_type :: String -> Direction -> String
 151 intf_vtbl_type ifn TX = ifscope ifn "tx_vtbl"
 152 intf_vtbl_type ifn RX = ifscope ifn "rx_vtbl"
 153
 154 connect_callback_name n = ifscope n "connect_fn"
 155 drv_connect_handler_name drv n = drvscope drv n "connect_handler"
 156 drv_connect_fn_name drv n = drvscope drv n "connect"
 157 drv_accept_fn_name drv n = drvscope drv n "accept"
 158 can_send_fn_name drv n = drvscope drv n "can_send"
 159 register_send_fn_name drv n = drvscope drv n "register_send"
 160 default_error_handler_fn_name drv n = drvscope drv n "default_error_handler"
 161 generic_control_fn_name drv n = drvscope drv n "control"
 162
 163 can_send_fn_type ifn = ifscope ifn "can_send_fn"
 164 register_send_fn_type ifn = ifscope ifn "register_send_fn"
 165 change_waitset_fn_type ifn = ifscope ifn "change_waitset_fn"
 166 control_fn_type ifn = ifscope ifn "control_fn"
 167 error_handler_fn_type ifn = ifscope ifn "error_handler_fn"
 168 receive_next_fn_type ifn = ifscope ifn "receive_next_fn"
 169 get_receiving_chanstate_fn_type ifn = ifscope ifn "get_receiving_chanstate_fn"
 170
 171 -- Name of the type of a message handler
 172 msg_handler_fn_name :: String -> MessageDef -> String
 173 msg_handler_fn_name ifn m = idscope ifn (msg_name m) "handler_fn"
 174
 175
 176
 177 ------------------------------------------------------------------------
 178 -- Code shared by backend implementations
 179 ------------------------------------------------------------------------
 180
 181 intf_preamble :: String -> String -> Maybe String -> C.Unit
 182 intf_preamble infile name descr =
 183     let dstr = case descr of
 184                  Nothing -> "not specified"
 185                  Just s -> s
 186     in
 187     C.MultiComment [
 188           "Copyright (c) 2010, ETH Zurich.",
 189           "All rights reserved.",
 190           "",
 191           "INTERFACE NAME: " ++ name,
 192           "INTEFACE FILE: " ++ infile,
 193           "INTERFACE DESCRIPTION: " ++ dstr,
 194           "",
 195           "This file is distributed under the terms in the attached LICENSE",
 196           "file. If you do not find this file, copies can be found by",
 197           "writing to:",
 198           "ETH Zurich D-INFK, Universitaetstr.6, CH-8092 Zurich.",
 199           "Attn: Systems Group.",
 200           "",
 201           "THIS FILE IS AUTOMATICALLY GENERATED BY FLOUNDER: DO NOT EDIT!" ]
 202
 203 --
 204 -- Convert each RPC definition to a pair of underlying call/response messages
 205 --
 206 rpcs_to_msgs :: [MessageDef] -> [MessageDef]
 207 rpcs_to_msgs ml = concat $ map rpc_to_msgs ml
 208
 209 rpc_to_msgs :: MessageDef -> [MessageDef]
 210 rpc_to_msgs (RPC n rpcargs bckargs) = [Message MCall (rpc_call_name n) inargs bckargs,
 211                                        Message MResponse (rpc_resp_name n) outargs bckargs]
 212     where
 213         (inargs, outargs) = partition_rpc_args rpcargs
 214 rpc_to_msgs m = [m]
 215
 216
 217 -- partition a list of RPC arguments to lists of input and output arguments
 218 partition_rpc_args :: [RPCArgument] -> ([MessageArgument], [MessageArgument])
 219 partition_rpc_args [] = ([], [])
 220 partition_rpc_args (first:rest) = case first of
 221     RPCArgIn t v -> ((Arg t v):restin, restout)
 222     RPCArgOut t v -> (restin, (Arg t v):restout)
 223     where
 224         (restin, restout) = partition_rpc_args rest
 225
 226 msg_argdecl :: Direction -> String -> MessageArgument -> [C.Param]
 227 msg_argdecl dir ifn (Arg tr (Name n)) =
 228     [ C.Param (type_c_type_dir dir ifn tr) n ]
 229 msg_argdecl dir ifn (Arg tr (StringArray n l)) =
 230     [ C.Param (type_c_type_dir dir ifn tr) n ]
 231 msg_argdecl RX ifn (Arg tr (DynamicArray n l _)) =
 232     [ C.Param (C.Ptr $ type_c_type_dir RX ifn tr) n,
 233       C.Param (type_c_type_dir RX ifn size) l ]
 234 msg_argdecl TX ifn (Arg tr (DynamicArray n l _)) =
 235     [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir TX ifn tr) n,
 236       C.Param (type_c_type_dir TX ifn size) l ]
 237
 238
 239 msg_argstructdecl :: Direction -> String -> [TypeDef] -> MessageArgument -> [C.Param]
 240 msg_argstructdecl dir ifn typedefs (Arg tr (Name n)) =
 241     [ C.Param (type_c_type_msgstruct dir ifn typedefs tr) n ]
 242 msg_argstructdecl RX ifn typedefs (Arg tr (StringArray n maxlen)) =
 243     [ C.Param (C.Array maxlen $ C.TypeName "char") (n)]
 244 msg_argstructdecl TX ifn typedefs (Arg tr (StringArray n maxlen)) =
 245     [ C.Param (type_c_type_dir TX ifn tr) n ]
 246 msg_argstructdecl RX ifn typedefs (Arg tr (DynamicArray n l maxlen)) =
 247     [ C.Param (C.Array maxlen $ type_c_type ifn tr) (n),
 248       C.Param (type_c_type ifn size) l ]
 249 msg_argstructdecl TX ifn typedefs (Arg tr (DynamicArray n l maxlen)) =
 250     [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir TX ifn tr) n,
 251       C.Param (type_c_type ifn size) l ]
 252
 253
 254 rpc_argdecl :: Direction -> String -> RPCArgument -> [C.Param]
 255 rpc_argdecl dir ifn (RPCArgIn tr v) = msg_argdecl dir ifn (Arg tr v)
 256 rpc_argdecl dir ifn (RPCArgOut tr (Name n)) = [ C.Param (C.Ptr $ type_c_type ifn tr) n ]
 257 rpc_argdecl dir ifn (RPCArgOut tr (StringArray n maxlen)) = [ C.Param (C.Array maxlen $ C.TypeName "char") n ]
 258 rpc_argdecl dir ifn (RPCArgOut tr (DynamicArray n l maxlen)) =
 259     [ C.Param (C.Array maxlen $ type_c_type ifn tr) n,
 260       C.Param (C.Ptr $ type_c_type ifn size) l ]
 261
 262 -- XXX: kludge wrapper to pass array types by reference in RPC
 263 rpc_argdecl2 :: Direction -> String -> [TypeDef] -> RPCArgument -> [C.Param]
 264 rpc_argdecl2 dir ifn typedefs arg@(RPCArgOut tr (Name n))
 265     = case lookup_typeref typedefs tr of
 266       TArray _ _ _ -> [ C.Param (type_c_type ifn tr) n ]
 267       _ -> rpc_argdecl dir ifn arg
 268 rpc_argdecl2 dir ifn _ arg = rpc_argdecl dir ifn arg
 269
 270 -- binding parameter for a function
 271 binding_param ifname = C.Param (C.Ptr $ C.Struct $ intf_bind_type ifname) intf_bind_var
 272 binding_param2 ifname = C.Param (C.Ptr $ C.Struct $ intf_bind_type ifname) (intf_bind_var ++ "_")
 273
 274
 275 --
 276 -- Generate the code to initialise/destroy a binding structure instance
 277 --
 278 binding_struct_init :: String -> String -> C.Expr -> C.Expr ->  C.Expr -> [C.Stmt]
 279 binding_struct_init drv ifn binding_var waitset_ex tx_vtbl_ex = [
 280     C.Ex $ C.Assignment (C.FieldOf binding_var "st") (C.Variable "NULL"),
 281     C.Ex $ C.Assignment (C.FieldOf binding_var "waitset") waitset_ex,
 282     C.Ex $ C.Assignment (C.FieldOf binding_var "send_waitset") (C.Variable "NULL"),
 283     C.Ex $ C.Call "event_mutex_init" [C.AddressOf $ C.FieldOf binding_var "mutex", waitset_ex],
 284     C.Ex $ C.Call "thread_mutex_init" [C.AddressOf $ C.FieldOf binding_var "rxtx_mutex"],
 285     C.Ex $ C.Call "thread_mutex_init" [C.AddressOf $ C.FieldOf binding_var "send_mutex"],
 286     C.Ex $ C.Assignment (C.FieldOf binding_var "can_send")
 287                                 (C.Variable $ can_send_fn_name drv ifn),
 288     C.Ex $ C.Assignment (C.FieldOf binding_var "register_send")
 289                                 (C.Variable $ register_send_fn_name drv ifn),
 290     C.Ex $ C.Assignment (C.FieldOf binding_var "error_handler")
 291                                 (C.Variable $ default_error_handler_fn_name drv ifn),
 292     C.Ex $ C.Assignment (C.FieldOf binding_var "tx_vtbl") tx_vtbl_ex,
 293     C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "rx_vtbl",
 294                             C.NumConstant 0,
 295                             C.Call "sizeof" [C.FieldOf binding_var "rx_vtbl"]],
 296     C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "message_rx_vtbl",
 297                             C.NumConstant 0,
 298                             C.Call "sizeof" [C.FieldOf binding_var "message_rx_vtbl"]],
 299     C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "rpc_rx_vtbl",
 300                             C.NumConstant 0,
 301                             C.Call "sizeof" [C.FieldOf binding_var "rpc_rx_vtbl"]],
 302     C.Ex $ C.Call "flounder_support_waitset_chanstate_init"
 303             [C.AddressOf $ C.FieldOf binding_var "register_chanstate"],
 304     C.Ex $ C.Call "flounder_support_waitset_chanstate_init"
 305             [C.AddressOf $ C.FieldOf binding_var "tx_cont_chanstate"],
 306     C.StmtList
 307         [C.Ex $ C.Assignment (C.FieldOf binding_var f) (C.NumConstant 0)
 308          | f <- ["tx_msgnum", "rx_msgnum", "tx_msg_fragment", "rx_msg_fragment",
 309                  "tx_str_pos", "rx_str_pos", "tx_str_len", "rx_str_len"]],
 310     C.Ex $ C.Assignment (C.FieldOf binding_var "incoming_token") (C.NumConstant 0),
 311     C.Ex $ C.Assignment (C.FieldOf binding_var "outgoing_token") (C.NumConstant 0)]
 312
 313 binding_struct_destroy :: String -> C.Expr -> [C.Stmt]
 314 binding_struct_destroy ifn binding_var
 315     = [C.Ex $ C.Call "flounder_support_waitset_chanstate_destroy"
 316             [C.AddressOf $ C.FieldOf binding_var "register_chanstate"],
 317        C.Ex $ C.Call "flounder_support_waitset_chanstate_destroy"
 318             [C.AddressOf $ C.FieldOf binding_var "tx_cont_chanstate"]]
 319
 320 --
 321 -- Generate a generic can_send function
 322 --
 323 can_send_fn_def :: String -> String -> C.Unit
 324 can_send_fn_def drv ifn =
 325     C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drv ifn) params [
 326         C.Return $ C.Binary C.Equals (bindvar `C.DerefField` "tx_msgnum") (C.NumConstant 0)
 327     ]
 328     where
 329         params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b" ]
 330         bindvar = C.Variable "b"
 331
 332 --
 333 -- generate a generic register_send function
 334 --
 335 register_send_fn_def :: String -> String -> C.Unit
 336 register_send_fn_def drv ifn =
 337     C.FunctionDef C.Static (C.TypeName "errval_t") (register_send_fn_name drv ifn) params [
 338         C.Return $ C.Call "flounder_support_register"
 339             [C.Variable "ws",
 340              C.AddressOf $ bindvar `C.DerefField` "register_chanstate",
 341              C.Variable intf_cont_var,
 342              C.Call (can_send_fn_name drv ifn) [bindvar]]
 343     ]
 344     where
 345         params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b",
 346                    C.Param (C.Ptr $ C.Struct "waitset") "ws",
 347                    C.Param (C.Struct "event_closure") intf_cont_var ]
 348         bindvar = C.Variable "b"
 349
 350 --
 351 -- generate a default error handler (which the user should replace!)
 352 --
 353 default_error_handler_fn_def :: String -> String -> C.Unit
 354 default_error_handler_fn_def drv ifn =
 355     C.FunctionDef C.Static C.Void (default_error_handler_fn_name drv ifn) params [
 356         C.Ex $ C.Call "DEBUG_ERR"
 357             [errvar, C.StringConstant $
 358              "asynchronous error in Flounder-generated " ++
 359              ifn ++ " " ++ drv ++ " binding (default handler)" ],
 360         C.Ex $ C.Call "abort" []
 361     ]
 362     where
 363         params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b",
 364                    C.Param (C.TypeName "errval_t") "err" ]
 365
 366 --
 367 -- generate a generic control function that does nothing
 368 --
 369 generic_control_fn_def :: String -> String -> C.Unit
 370 generic_control_fn_def drv ifn =
 371     C.FunctionDef C.Static (C.TypeName "errval_t") (generic_control_fn_name drv ifn) params [
 372         C.SComment "no control flags are supported",
 373         C.Return $ C.Variable "SYS_ERR_OK"
 374     ]
 375     where
 376         params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var,
 377                   C.Param (C.TypeName "idc_control_t") "control"]
 378
 379 -- register a transmit continuation
 380 register_txcont :: C.Expr -> [C.Stmt]
 381 register_txcont cont_ex = [
 382     C.If (C.Binary C.NotEquals (cont_ex `C.FieldOf` "handler") (C.Variable "NULL"))
 383         [localvar (C.TypeName "errval_t") "_err" Nothing,
 384          C.Ex $ C.Assignment errvar $ C.Call "flounder_support_register"
 385             [C.Variable "send_waitset",
 386              C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate",
 387              cont_ex,
 388              C.Variable "false"],
 389          C.SComment "may fail if previous continuation hasn't fired yet",
 390          C.If (C.Call "err_is_fail" [errvar])
 391             [C.If (C.Binary C.Equals (C.Call "err_no" [errvar])
 392                                      (C.Variable "LIB_ERR_CHAN_ALREADY_REGISTERED"))
 393                 [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"],
 394                  C.Ex $ C.Call "assert" [C.Binary C.NotEquals (cont_ex `C.FieldOf` "handler") (C.Variable "blocking_cont")],
 395                  C.Return $ C.Variable "FLOUNDER_ERR_TX_BUSY"]
 396                 [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"],
 397                  C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "shouldn't happen"],
 398                  C.Return $ errvar] ] []
 399          ] []
 400     ] where
 401         errvar = C.Variable "_err"
 402
 403 block_sending :: C.Expr -> [C.Stmt]
 404 block_sending cont_ex = [
 405     C.If (C.Binary C.Equals (cont_ex `C.FieldOf` "handler") (C.Variable "blocking_cont"))
 406         [C.If (C.Binary C.Equals binding_error (C.Variable "SYS_ERR_OK")) [
 407             C.Ex $ C.Assignment binding_error $ C.Call "wait_for_channel"
 408                 [C.Variable "send_waitset", tx_cont_chanstate, C.AddressOf binding_error]
 409             ] [
 410             C.Ex $ C.Call "flounder_support_deregister_chan" [tx_cont_chanstate]
 411             ]
 412         ] []
 413     ] where
 414         errvar = C.Variable "_err"
 415         mask = C.CallInd (C.DerefField bindvar "get_receiving_chanstate") [bindvar]
 416         tx_cont_chanstate = C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate"
 417
 418 -- starting a send: just a debug hook
 419 start_send :: String -> String -> String -> [MessageArgument] -> [C.Stmt]
 420 start_send drvn ifn mn msgargs
 421     = [C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
 422                                  drvn ++ " TX " ++ ifn ++ "." ++ mn ++ "\n"]]
 423
 424 -- finished a send: clear msgnum, trigger pending waitsets/events
 425 finished_send :: [C.Stmt]
 426 finished_send = [
 427     C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0)] ++
 428     [C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr ws]
 429     | ws <- ["tx_cont_chanstate", "register_chanstate"]]
 430     where
 431         tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
 432         wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws
 433
 434 -- start receiving: allocate space for any static arrays in message
 435 start_recv :: String -> String -> [TypeDef] -> String -> [MessageArgument] -> [C.Stmt]
 436 start_recv drvn ifn typedefs mn msgargs
 437   = concat [
 438     [C.Ex $ C.Assignment (field fn)
 439           $ C.Call "malloc" [C.SizeOfT $ type_c_type ifn tr],
 440      C.Ex $ C.Call "assert" [C.Binary C.NotEquals (field fn) (C.Variable "NULL")]
 441     ] | Arg tr (Name fn) <- msgargs, is_array tr]
 442
 443     where
 444       field fn = rx_union_elem mn fn
 445       is_array tr = case lookup_typeref typedefs tr of
 446         TArray _ _ _ -> True
 447         _ -> False
 448
 449 -- finished recv: debug, run handler and clean up
 450 finished_recv :: String -> String -> [TypeDef] ->  MessageType -> String -> [MessageArgument] -> [C.Stmt]
 451 finished_recv drvn ifn typedefs mtype mn msgargs
 452     = [ C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
 453                                  drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"],
 454         C.If (C.Binary C.NotEquals handler (C.Variable "NULL"))
 455             [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token,
 456              C.Ex $ C.CallInd handler (bindvar:args)]
 457             [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token,
 458              C.Ex $ C.Call "flounder_support_trigger_chan" [C.AddressOf message_chanstate],
 459              C.Ex $ C.Assignment (C.Variable "no_register") (C.NumConstant 1)],
 460         C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)]
 461     where
 462         rx_msgnum_field = C.DerefField bindvar "rx_msgnum"
 463         handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
 464         args = concat [mkargs tr a | Arg tr a <- msgargs]
 465         mkargs tr (Name n) = case lookup_typeref typedefs tr of
 466           TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n]
 467           _ -> [rx_union_elem mn n]
 468         mkargs _ (StringArray n l) = [rx_union_elem mn n]
 469         mkargs _ (DynamicArray n l _) = [rx_union_elem mn n, rx_union_elem mn l]
 470         binding_incoming_token = C.DerefField bindvar "incoming_token"
 471         message_chanstate = C.SubscriptOf (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn)
 472
 473 finished_recv_nocall :: String -> String -> [TypeDef] ->  MessageType -> String -> [MessageArgument] -> [C.Stmt]
 474 finished_recv_nocall drvn ifn typedefs mtype mn msgargs
 475     = [ C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
 476                                  drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"],
 477         C.If (C.Binary C.NotEquals handler (C.Variable "NULL"))
 478             [C.Ex $ C.Assignment (C.Variable "call_msgnum") (C.Variable $ msg_enum_elem_name ifn mn)]
 479             [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token,
 480              C.Ex $ C.Call "flounder_support_trigger_chan" [C.AddressOf message_chanstate],
 481              C.Ex $ C.Assignment (C.Variable "no_register") (C.NumConstant 1)],
 482         C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)]
 483     where
 484         rx_msgnum_field = C.DerefField bindvar "rx_msgnum"
 485         handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
 486         binding_incoming_token = C.DerefField bindvar "incoming_token"
 487         message_chanstate = C.SubscriptOf (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn)
 488
 489 -- call callback, directly from a receiving handler
 490 call_handler :: String -> String -> [TypeDef] ->  MessageType -> String -> [MessageArgument] -> [C.Stmt]
 491 call_handler drvn ifn typedefs mtype mn msgargs
 492     =   [C.Ex $ C.CallInd handler (bindvar:args)]
 493     where
 494         handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
 495         args = concat [mkargs tr a | Arg tr a <- msgargs]
 496         mkargs tr (Name n) = case lookup_typeref typedefs tr of
 497           TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n]
 498           _ -> [rx_union_elem mn n]
 499         mkargs _ (StringArray n l) = [rx_union_elem mn n]
 500         mkargs _ (DynamicArray n l _) = [rx_union_elem mn n, rx_union_elem mn l]
 501
 502 -- call callback, from a message handler
 503 call_message_handler_msgargs :: String -> String -> [TypeDef] -> [MessageArgument] -> [C.Stmt]
 504 call_message_handler_msgargs ifn mn typedefs msgargs
 505         = [C.Ex $ C.CallInd handler (bindvar:args)]
 506     where
 507         handler = C.DerefField bindvar "message_rx_vtbl" `C.FieldOf` mn
 508         args = concat [mkargs a | Arg tr a <- msgargs]
 509         mkargs (Name n) = [local_rx_union_elem mn n]
 510         mkargs (StringArray n l) = [local_rx_union_elem mn n]
 511         mkargs (DynamicArray n l _) = [local_rx_union_elem mn n, local_rx_union_elem mn l]
 512
 513 -- call callback, from a rpc handler
 514 call_message_handler_rpcargs :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt]
 515 call_message_handler_rpcargs ifn mn typedefs msgargs
 516         = [C.Ex $ C.Call "assert" [handler],
 517         C.Ex $ C.CallInd handler (bindvar:args)]
 518     where
 519         handler = C.DerefField bindvar "message_rx_vtbl" `C.FieldOf` (rpc_call_name mn)
 520         args = concat [mkargs a | RPCArgIn tr a <- msgargs]
 521         mkargs (Name n) = [local_rx_union_elem mn n]
 522         mkargs (StringArray n l) = [local_rx_union_elem mn n]
 523         mkargs (DynamicArray n l _) = [local_rx_union_elem mn n, local_rx_union_elem mn l]
 524
 525 -- call rpc callback
 526 call_rpc_handler :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt]
 527 call_rpc_handler ifn mn typedefs msgargs
 528         = [C.Ex $ C.CallInd handler (bindvar:args)]
 529     where
 530         handler = C.DerefField bindvar "rpc_rx_vtbl" `C.FieldOf` (rpc_call_name mn)
 531         args = concat [mkargs a | a <- msgargs]
 532         mkargs (RPCArgIn _ (Name n)) = [local_rx_union_elem mn n]
 533         mkargs (RPCArgIn _ (StringArray n l)) = [local_rx_union_elem mn n]
 534         mkargs (RPCArgIn _ (DynamicArray n l _)) = [local_rx_union_elem mn n, local_rx_union_elem mn l]
 535         mkargs (RPCArgOut tr (Name n)) = case lookup_typeref typedefs tr of
 536           TArray _ _ _ -> [C.DerefPtr $ local_tx_union_elem mn n]
 537           _ -> [C.AddressOf $ local_tx_union_elem mn n]
 538         mkargs (RPCArgOut _ (StringArray n l)) = [local_tx_union_elem mn n]
 539         mkargs (RPCArgOut _ (DynamicArray n l _)) = [local_tx_union_elem mn n, C.AddressOf $ local_tx_union_elem mn l]
 540
 541 -- send response
 542 send_response :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt]
 543 send_response ifn mn typedefs msgargs
 544         = [C.Ex $ C.Call "assert" [handler],
 545         C.Ex $ C.Assignment errvar $ C.CallInd handler (bindvar:cont:args),
 546         C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]]
 547     where
 548         handler = C.DerefField bindvar "tx_vtbl" `C.FieldOf` (rpc_resp_name mn)
 549         args = concat [mkargs tr a | RPCArgOut tr a <- msgargs]
 550         mkargs tr (Name n) = case lookup_typeref typedefs tr of
 551           TArray _ _ _ -> [C.DerefPtr $ local_tx_union_elem mn n]
 552           _ -> [local_tx_union_elem mn n]
 553         mkargs _ (StringArray n l) = [local_tx_union_elem mn n]
 554         mkargs _ (DynamicArray n l _) = [local_tx_union_elem mn n, local_tx_union_elem mn l]
 555         cont = C.Variable "BLOCKING_CONT"
 556
 557 tx_arg_assignment :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt
 558 tx_arg_assignment ifn typedefs mn (Arg tr v) = case v of
 559     Name an -> C.Ex $ C.Assignment (tx_union_elem mn an) (srcarg an)
 560     StringArray an _ -> C.Ex $ C.Assignment (tx_union_elem mn an) ((C.Variable an))
 561     DynamicArray an len _ -> C.StmtList [
 562         C.Ex $ C.Assignment (tx_union_elem mn an) (C.Cast (C.Ptr typespec) (C.Variable an)),
 563         C.Ex $ C.Assignment (tx_union_elem mn len) (C.Variable len)]
 564     where
 565         typespec = type_c_type ifn tr
 566         srcarg an =
 567           case lookup_typeref typedefs tr of
 568             -- XXX: I have no idea why GCC requires a cast for the array type
 569             TArray _ _ _ -> C.Cast (C.Ptr typespec) (C.Variable an)
 570             _             -> case typespec of
 571               -- we may need to cast away the const on a pointer
 572               C.Ptr _ -> C.Cast typespec (C.Variable an)
 573               _ -> C.Variable an
 574
 575
 576 -- extracts the size of the arguemnts of a message
 577 extract_msg_size :: MessageArgument -> Integer
 578 extract_msg_size (Arg tr (Name an)) = 0
 579 extract_msg_size (Arg tr (StringArray an maxlen)) = maxlen
 580 extract_msg_size (Arg tr (DynamicArray an len maxlen)) = maxlen
 581
 582 -- extracts the size of the arguemnts of an RPC (in)
 583 extract_rpc_size_in :: RPCArgument -> Integer
 584 extract_rpc_size_in (RPCArgIn tr (Name an)) = 0
 585 extract_rpc_size_in (RPCArgIn tr (StringArray an maxlen)) = maxlen
 586 extract_rpc_size_in (RPCArgIn tr (DynamicArray an len maxlen)) = maxlen
 587
 588 -- extracts the size of the arguemnts of an RPC (out)
 589 extract_rpc_size_out :: RPCArgument -> Integer
 590 extract_rpc_size_out (RPCArgOut tr (Name an)) = 0
 591 extract_rpc_size_out (RPCArgOut tr (StringArray an maxlen)) = maxlen
 592 extract_rpc_size_out (RPCArgOut tr (DynamicArray an len maxlen)) = maxlen
 593
 594 -- extract the size of arguemnts
 595 msg_arg_extract_length :: MessageDef -> Integer
 596 msg_arg_extract_length (RPC n [] _) = 0
 597 msg_arg_extract_length (RPC n args _) = maximum [ sum $ [ extract_rpc_size_in arg | arg <- args], sum $ [ extract_rpc_size_out arg | arg <- args]]
 598 msg_arg_extract_length (Message mtype n [] _) = 0
 599 msg_arg_extract_length (Message mtype n args _) = sum $ [ extract_msg_size arg | arg <- args]
 600
 601
 602
 603 -- checks the size of the MSG arguments
 604 tx_fn_arg_check_size :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt
 605 tx_fn_arg_check_size ifn typedefs mn (Arg tr v) = case v of
 606     Name an -> C.SComment (an ++ " has a base type. no length check")
 607     StringArray an maxlen -> C.StmtList [
 608         C.SComment ("checking datalength of " ++ an),
 609         C.If (C.Binary C.And (C.Variable an)
 610               (C.Binary C.GreaterThanEq (C.Call "strlen" [C.Variable an]) (C.NumConstant maxlen))) [
 611             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
 612         ] []
 613         ]
 614     DynamicArray an len maxlen -> C.StmtList [
 615         C.SComment ("checking datalength of " ++ an),
 616         C.If (C.Binary C.GreaterThan (C.Variable len) (C.NumConstant maxlen)) [
 617             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
 618         ] []
 619         ]
 620
 621 -- checks the size of the RPC arguments
 622 tx_fn_arg_check_size_rpc :: String -> [TypeDef] -> String -> RPCArgument -> C.Stmt
 623 tx_fn_arg_check_size_rpc ifn typedefs mn (RPCArgIn tr v) = case v of
 624     Name an -> C.SComment (an ++ " has a base type. no length check")
 625     StringArray an maxlen -> C.StmtList [
 626         C.SComment ("checking datalength of " ++ an),
 627         C.If (C.Binary C.And (C.Variable an)
 628               (C.Binary C.GreaterThanEq (C.Call "strlen" [C.Variable an]) (C.NumConstant maxlen)))[
 629             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
 630         ] []
 631         ]
 632     DynamicArray an len maxlen -> C.StmtList [
 633         C.SComment ("checking datalength of " ++ an),
 634         C.If (C.Binary C.GreaterThan (C.Variable len) (C.NumConstant maxlen)) [
 635             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
 636         ] []
 637         ]
 638 tx_fn_arg_check_size_rpc ifn typedefs mn (RPCArgOut tr v) = C.SComment (" Is out arg")
 639
 640
 641 tx_union_elem :: String -> String -> C.Expr
 642 tx_union_elem mn fn
 643    = bindvar `C.DerefField` "tx_union" `C.FieldOf` mn `C.FieldOf` fn
 644
 645 rx_union_elem :: String -> String -> C.Expr
 646 rx_union_elem mn fn
 647    = bindvar `C.DerefField` "rx_union" `C.FieldOf` mn `C.FieldOf` fn
 648
 649 local_rx_union_elem :: String -> String -> C.Expr
 650 local_rx_union_elem mn fn
 651    = (C.Variable "arguments") `C.FieldOf` fn
 652
 653 local_tx_union_elem :: String -> String -> C.Expr
 654 local_tx_union_elem mn fn
 655    = (C.Variable "result") `C.FieldOf` fn
 656
 657 -- misc common bits of C
 658 localvar = C.VarDecl C.NoScope C.NonConst
 659 errvar = C.Variable "err"
 660 bindvar = C.Variable intf_bind_var
 661 binding_error = C.DerefField bindvar "error"
 662 clear_error = C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK")
 663 report_user_err ex = C.StmtList [
 664     C.Ex $ C.Assignment (C.DerefField bindvar "error") ex,
 665     C.If (C.DerefField bindvar "error_handler") [
 666         C.Ex $ C.CallInd (C.DerefField bindvar "error_handler") [bindvar, ex]
 667     ] []]
 668
 669 report_user_tx_err ex = C.StmtList [
 670     report_user_err ex,
 671     C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0),
 672     C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr "register_chanstate"],
 673     C.Ex $ C.Call "flounder_support_deregister_chan" [wsaddr "tx_cont_chanstate"]
 674     ] where
 675         tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
 676         wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws