e75f31a6e4bb11b6760bbbeec9dd89fde0f3c8d2
[barrelfish] / 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.Call "thread_set_mask_channels" [C.Variable "true"],
408             C.Ex $ C.Assignment binding_error $ C.Call "wait_for_channel"
409                 [C.Variable "send_waitset", tx_cont_chanstate, C.AddressOf binding_error],
410             C.Ex $ C.Call "thread_set_mask_channels" [C.Variable "false"]
411             ] [
412             C.Ex $ C.Call "flounder_support_deregister_chan" [tx_cont_chanstate]
413             ]
414         ] []
415     ] where
416         errvar = C.Variable "_err"
417         mask = C.CallInd (C.DerefField bindvar "get_receiving_chanstate") [bindvar]
418         tx_cont_chanstate = C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate"
419
420 -- starting a send: just a debug hook
421 start_send :: String -> String -> String -> [MessageArgument] -> [C.Stmt]
422 start_send drvn ifn mn msgargs
423     = [C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
424                                  drvn ++ " TX " ++ ifn ++ "." ++ mn ++ "\n"]]
425
426 -- finished a send: clear msgnum, trigger pending waitsets/events
427 finished_send :: [C.Stmt]
428 finished_send = [
429     C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0)] ++
430     [C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr ws]
431     | ws <- ["tx_cont_chanstate", "register_chanstate"]]
432     where
433         tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
434         wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws
435
436 -- start receiving: allocate space for any static arrays in message
437 start_recv :: String -> String -> [TypeDef] -> String -> [MessageArgument] -> [C.Stmt]
438 start_recv drvn ifn typedefs mn msgargs
439   = concat [
440     [C.Ex $ C.Assignment (field fn)
441           $ C.Call "malloc" [C.SizeOfT $ type_c_type ifn tr],
442      C.Ex $ C.Call "assert" [C.Binary C.NotEquals (field fn) (C.Variable "NULL")]
443     ] | Arg tr (Name fn) <- msgargs, is_array tr]
444
445     where
446       field fn = rx_union_elem mn fn
447       is_array tr = case lookup_typeref typedefs tr of
448         TArray _ _ _ -> True
449         _ -> False
450
451 -- finished recv: debug, run handler and clean up
452 finished_recv :: String -> String -> [TypeDef] ->  MessageType -> String -> [MessageArgument] -> [C.Stmt]
453 finished_recv drvn ifn typedefs mtype mn msgargs
454     = [ C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
455                                  drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"],
456         C.If (C.Binary C.NotEquals handler (C.Variable "NULL"))
457             [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token,
458              C.Ex $ C.CallInd handler (bindvar:args)]
459             [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token,
460              C.Ex $ C.Call "flounder_support_trigger_chan" [C.AddressOf message_chanstate],
461              C.Ex $ C.Assignment (C.Variable "no_register") (C.NumConstant 1)],
462         C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)]
463     where
464         rx_msgnum_field = C.DerefField bindvar "rx_msgnum"
465         handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
466         args = concat [mkargs tr a | Arg tr a <- msgargs]
467         mkargs tr (Name n) = case lookup_typeref typedefs tr of
468           TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n]
469           _ -> [rx_union_elem mn n]
470         mkargs _ (StringArray n l) = [rx_union_elem mn n]
471         mkargs _ (DynamicArray n l _) = [rx_union_elem mn n, rx_union_elem mn l]
472         binding_incoming_token = C.DerefField bindvar "incoming_token"
473         message_chanstate = C.SubscriptOf (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn)
474
475 finished_recv_nocall :: String -> String -> [TypeDef] ->  MessageType -> String -> [MessageArgument] -> [C.Stmt]
476 finished_recv_nocall drvn ifn typedefs mtype mn msgargs
477     = [ C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $
478                                  drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"],
479         C.If (C.Binary C.NotEquals handler (C.Variable "NULL"))
480             [C.Ex $ C.Assignment (C.Variable "call_msgnum") (C.Variable $ msg_enum_elem_name ifn mn)]
481             [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token,
482              C.Ex $ C.Call "flounder_support_trigger_chan" [C.AddressOf message_chanstate],
483              C.Ex $ C.Assignment (C.Variable "no_register") (C.NumConstant 1)],
484         C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)]
485     where
486         rx_msgnum_field = C.DerefField bindvar "rx_msgnum"
487         handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
488         binding_incoming_token = C.DerefField bindvar "incoming_token"
489         message_chanstate = C.SubscriptOf (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn)
490
491 -- call callback, directly from a receiving handler
492 call_handler :: String -> String -> [TypeDef] ->  MessageType -> String -> [MessageArgument] -> [C.Stmt]
493 call_handler drvn ifn typedefs mtype mn msgargs
494     =   [C.Ex $ C.CallInd handler (bindvar:args)]
495     where
496         handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn
497         args = concat [mkargs tr a | Arg tr a <- msgargs]
498         mkargs tr (Name n) = case lookup_typeref typedefs tr of
499           TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n]
500           _ -> [rx_union_elem mn n]
501         mkargs _ (StringArray n l) = [rx_union_elem mn n]
502         mkargs _ (DynamicArray n l _) = [rx_union_elem mn n, rx_union_elem mn l]
503
504 -- call callback, from a message handler
505 call_message_handler_msgargs :: String -> String -> [TypeDef] -> [MessageArgument] -> [C.Stmt]
506 call_message_handler_msgargs ifn mn typedefs msgargs
507         = [C.Ex $ C.CallInd handler (bindvar:args)]
508     where
509         handler = C.DerefField bindvar "message_rx_vtbl" `C.FieldOf` mn
510         args = concat [mkargs a | Arg tr a <- msgargs]
511         mkargs (Name n) = [local_rx_union_elem mn n]
512         mkargs (StringArray n l) = [local_rx_union_elem mn n]
513         mkargs (DynamicArray n l _) = [local_rx_union_elem mn n, local_rx_union_elem mn l]
514
515 -- call callback, from a rpc handler
516 call_message_handler_rpcargs :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt]
517 call_message_handler_rpcargs ifn mn typedefs msgargs
518         = [C.Ex $ C.Call "assert" [handler],
519         C.Ex $ C.CallInd handler (bindvar:args)]
520     where
521         handler = C.DerefField bindvar "message_rx_vtbl" `C.FieldOf` (rpc_call_name mn)
522         args = concat [mkargs a | RPCArgIn tr a <- msgargs]
523         mkargs (Name n) = [local_rx_union_elem mn n]
524         mkargs (StringArray n l) = [local_rx_union_elem mn n]
525         mkargs (DynamicArray n l _) = [local_rx_union_elem mn n, local_rx_union_elem mn l]
526
527 -- call rpc callback
528 call_rpc_handler :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt]
529 call_rpc_handler ifn mn typedefs msgargs
530         = [C.Ex $ C.CallInd handler (bindvar:args)]
531     where
532         handler = C.DerefField bindvar "rpc_rx_vtbl" `C.FieldOf` (rpc_call_name mn)
533         args = concat [mkargs a | a <- msgargs]
534         mkargs (RPCArgIn _ (Name n)) = [local_rx_union_elem mn n]
535         mkargs (RPCArgIn _ (StringArray n l)) = [local_rx_union_elem mn n]
536         mkargs (RPCArgIn _ (DynamicArray n l _)) = [local_rx_union_elem mn n, local_rx_union_elem mn l]
537         mkargs (RPCArgOut tr (Name n)) = case lookup_typeref typedefs tr of
538           TArray _ _ _ -> [C.DerefPtr $ local_tx_union_elem mn n]
539           _ -> [C.AddressOf $ local_tx_union_elem mn n]
540         mkargs (RPCArgOut _ (StringArray n l)) = [local_tx_union_elem mn n]
541         mkargs (RPCArgOut _ (DynamicArray n l _)) = [local_tx_union_elem mn n, C.AddressOf $ local_tx_union_elem mn l]
542
543 -- send response
544 send_response :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt]
545 send_response ifn mn typedefs msgargs
546         = [C.Ex $ C.Call "assert" [handler],
547         C.Ex $ C.Assignment errvar $ C.CallInd handler (bindvar:cont:args),
548         C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]]
549     where
550         handler = C.DerefField bindvar "tx_vtbl" `C.FieldOf` (rpc_resp_name mn)
551         args = concat [mkargs tr a | RPCArgOut tr a <- msgargs]
552         mkargs tr (Name n) = case lookup_typeref typedefs tr of
553           TArray _ _ _ -> [C.DerefPtr $ local_tx_union_elem mn n]
554           _ -> [local_tx_union_elem mn n]
555         mkargs _ (StringArray n l) = [local_tx_union_elem mn n]
556         mkargs _ (DynamicArray n l _) = [local_tx_union_elem mn n, local_tx_union_elem mn l]
557         cont = C.Variable "BLOCKING_CONT"
558
559 tx_arg_assignment :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt
560 tx_arg_assignment ifn typedefs mn (Arg tr v) = case v of
561     Name an -> C.Ex $ C.Assignment (tx_union_elem mn an) (srcarg an)
562     StringArray an _ -> C.Ex $ C.Assignment (tx_union_elem mn an) ((C.Variable an))
563     DynamicArray an len _ -> C.StmtList [
564         C.Ex $ C.Assignment (tx_union_elem mn an) (C.Cast (C.Ptr typespec) (C.Variable an)),
565         C.Ex $ C.Assignment (tx_union_elem mn len) (C.Variable len)]
566     where
567         typespec = type_c_type ifn tr
568         srcarg an =
569           case lookup_typeref typedefs tr of
570             -- XXX: I have no idea why GCC requires a cast for the array type
571             TArray _ _ _ -> C.Cast (C.Ptr typespec) (C.Variable an)
572             _             -> case typespec of
573               -- we may need to cast away the const on a pointer
574               C.Ptr _ -> C.Cast typespec (C.Variable an)
575               _ -> C.Variable an
576
577
578 -- extracts the size of the arguemnts of a message
579 extract_msg_size :: MessageArgument -> Integer
580 extract_msg_size (Arg tr (Name an)) = 0
581 extract_msg_size (Arg tr (StringArray an maxlen)) = maxlen
582 extract_msg_size (Arg tr (DynamicArray an len maxlen)) = maxlen
583
584 -- extracts the size of the arguemnts of an RPC (in)
585 extract_rpc_size_in :: RPCArgument -> Integer
586 extract_rpc_size_in (RPCArgIn tr (Name an)) = 0
587 extract_rpc_size_in (RPCArgIn tr (StringArray an maxlen)) = maxlen
588 extract_rpc_size_in (RPCArgIn tr (DynamicArray an len maxlen)) = maxlen
589
590 -- extracts the size of the arguemnts of an RPC (out)
591 extract_rpc_size_out :: RPCArgument -> Integer
592 extract_rpc_size_out (RPCArgOut tr (Name an)) = 0
593 extract_rpc_size_out (RPCArgOut tr (StringArray an maxlen)) = maxlen
594 extract_rpc_size_out (RPCArgOut tr (DynamicArray an len maxlen)) = maxlen
595
596 -- extract the size of arguemnts
597 msg_arg_extract_length :: MessageDef -> Integer
598 msg_arg_extract_length (RPC n [] _) = 0
599 msg_arg_extract_length (RPC n args _) = maximum [ sum $ [ extract_rpc_size_in arg | arg <- args], sum $ [ extract_rpc_size_out arg | arg <- args]]
600 msg_arg_extract_length (Message mtype n [] _) = 0
601 msg_arg_extract_length (Message mtype n args _) = sum $ [ extract_msg_size arg | arg <- args]
602
603
604
605 -- checks the size of the MSG arguments
606 tx_fn_arg_check_size :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt
607 tx_fn_arg_check_size ifn typedefs mn (Arg tr v) = case v of
608     Name an -> C.SComment (an ++ " has a base type. no length check")
609     StringArray an maxlen -> C.StmtList [
610         C.SComment ("checking datalength of " ++ an),
611         C.If (C.Binary C.And (C.Variable an)
612               (C.Binary C.GreaterThanEq (C.Call "strlen" [C.Variable an]) (C.NumConstant maxlen))) [
613             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
614         ] []
615         ]
616     DynamicArray an len maxlen -> C.StmtList [
617         C.SComment ("checking datalength of " ++ an),
618         C.If (C.Binary C.GreaterThan (C.Variable len) (C.NumConstant maxlen)) [
619             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
620         ] []
621         ]
622
623 -- checks the size of the RPC arguments
624 tx_fn_arg_check_size_rpc :: String -> [TypeDef] -> String -> RPCArgument -> C.Stmt
625 tx_fn_arg_check_size_rpc ifn typedefs mn (RPCArgIn tr v) = case v of
626     Name an -> C.SComment (an ++ " has a base type. no length check")
627     StringArray an maxlen -> C.StmtList [
628         C.SComment ("checking datalength of " ++ an),
629         C.If (C.Binary C.And (C.Variable an)
630               (C.Binary C.GreaterThanEq (C.Call "strlen" [C.Variable an]) (C.NumConstant maxlen)))[
631             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
632         ] []
633         ]
634     DynamicArray an len maxlen -> C.StmtList [
635         C.SComment ("checking datalength of " ++ an),
636         C.If (C.Binary C.GreaterThan (C.Variable len) (C.NumConstant maxlen)) [
637             C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE")
638         ] []
639         ]
640 tx_fn_arg_check_size_rpc ifn typedefs mn (RPCArgOut tr v) = C.SComment (" Is out arg")
641
642
643 tx_union_elem :: String -> String -> C.Expr
644 tx_union_elem mn fn
645    = bindvar `C.DerefField` "tx_union" `C.FieldOf` mn `C.FieldOf` fn
646
647 rx_union_elem :: String -> String -> C.Expr
648 rx_union_elem mn fn
649    = bindvar `C.DerefField` "rx_union" `C.FieldOf` mn `C.FieldOf` fn
650
651 local_rx_union_elem :: String -> String -> C.Expr
652 local_rx_union_elem mn fn
653    = (C.Variable "arguments") `C.FieldOf` fn
654
655 local_tx_union_elem :: String -> String -> C.Expr
656 local_tx_union_elem mn fn
657    = (C.Variable "result") `C.FieldOf` fn
658
659 -- misc common bits of C
660 localvar = C.VarDecl C.NoScope C.NonConst
661 errvar = C.Variable "err"
662 bindvar = C.Variable intf_bind_var
663 binding_error = C.DerefField bindvar "error"
664 clear_error = C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK")
665 report_user_err ex = C.StmtList [
666     C.Ex $ C.Assignment (C.DerefField bindvar "error") ex,
667     C.If (C.DerefField bindvar "error_handler") [
668         C.Ex $ C.CallInd (C.DerefField bindvar "error_handler") [bindvar, ex]
669     ] []]
670
671 report_user_tx_err ex = C.StmtList [
672     report_user_err ex,
673     C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0),
674     C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr "register_chanstate"],
675     C.Ex $ C.Call "flounder_support_deregister_chan" [wsaddr "tx_cont_chanstate"]
676     ] where
677         tx_msgnum_field = C.DerefField bindvar "tx_msgnum"
678         wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws