1{- 
2  THCBackend: generate interface to Flounder THC stubs
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
14module THCBackend where
15
16import Data.List
17
18import qualified CAbsSyntax as C
19import qualified BackendCommon as BC
20import Syntax
21import Backend
22
23------------------------------------------------------------------------
24-- Language mapping: C identifier names
25------------------------------------------------------------------------
26
27-- Name of the struct holding message args for SAR
28msg_argstruct_name :: String -> String -> String
29msg_argstruct_name ifn n = idscope ifn n "args_t"
30
31rpc_argstruct_name :: String -> String -> String -> String
32rpc_argstruct_name ifn n inout = idscope ifn n (inout ++ "_args_t")
33
34rpc_union_name :: String -> String -> String
35rpc_union_name ifn n = idscope ifn n "_union_t"
36
37-- Name of the enumeration of message numbers
38msg_enum_name :: String -> String
39msg_enum_name ifn = ifscope ifn "msg_enum_t"
40
41call_msg_enum_name :: String -> String
42call_msg_enum_name ifn = ifscope ifn "call_msg_enum_t"
43
44resp_msg_enum_name :: String -> String
45resp_msg_enum_name ifn = ifscope ifn "resp_msg_enum_t"
46
47-- Name of each element of the message number enumeration
48msg_enum_elem_name :: String -> String -> String
49msg_enum_elem_name ifn mn = ifscope ifn mn
50
51call_msg_enum_elem_name :: String -> String -> String
52call_msg_enum_elem_name ifn mn = ifscope ifn ("_call_" ++ mn)
53
54resp_msg_enum_elem_name :: String -> String -> String
55resp_msg_enum_elem_name ifn mn = ifscope ifn ("_resp_" ++ mn)
56
57-- Name of the union type holding all the arguments for a message
58binding_arg_union_type :: String -> String
59binding_arg_union_type ifn = ifscope ifn "thc_arg_union"
60
61-- Scope a list of strings
62ifscope :: String -> String -> String
63ifscope ifn s = ifn ++ "_" ++ s
64
65idscope :: String -> String -> String -> String
66idscope ifn s suffix  = ifscope ifn (s ++ "__" ++ suffix)
67
68-- Name of the binding struct for an interface type
69intf_bind_type :: String -> String -> String
70intf_bind_type ifn sender = ifscope ifn $ "thc_" ++ sender ++ "_binding_t"
71
72-- Variable used to refer to a binding
73intf_bind_var = "_thc_binding"
74
75-- Name of the type of a message function
76msg_sig_type :: String -> String -> String -> MessageDef -> String
77msg_sig_type ifn sender sendrecv m = idscope ifn (BC.msg_name m) "thc_" ++ sender ++ "_" ++ sendrecv ++ "_t"
78msg_sig_type_x :: String -> String -> String -> MessageDef -> String
79msg_sig_type_x ifn sender sendrecv m = idscope ifn (BC.msg_name m) "thc_" ++ sender ++ "_" ++ sendrecv ++ "_t_x"
80
81-- Name of the type of an RPC call function
82call_sig_type :: String -> MessageDef -> String
83call_sig_type ifn m@(RPC n _ _) = idscope ifn n "thc_call__t"
84
85call_sig_type_x :: String -> MessageDef -> String
86call_sig_type_x ifn m@(RPC n _ _) = idscope ifn n "thc_call__t_x"
87
88call_ooo_sig_type :: String -> MessageDef -> String
89call_ooo_sig_type ifn m@(RPC n _ _) = idscope ifn n "thc_ooo_call__t"
90
91call_ooo_sig_type_x :: String -> MessageDef -> String
92call_ooo_sig_type_x ifn m@(RPC n _ _) = idscope ifn n "thc_ooo_call__t_x"
93
94-- Name of the type of a receive-any function
95rx_any_sig_type :: String -> String -> String
96rx_any_sig_type ifn receiver = idscope ifn "recv_any" "thc_" ++ receiver ++ "_t"
97
98rx_any_sig_type_x :: String -> String -> String
99rx_any_sig_type_x ifn receiver = idscope ifn "recv_any" "thc_" ++ receiver ++ "_t_x"
100
101-- Name of the structure in which receive-any supplies a message
102rx_any_struct_name :: String -> String -> String
103rx_any_struct_name ifn receiver = ifscope ifn (receiver ++ "_msg")
104
105rx_any_type_name :: String -> String -> String
106rx_any_type_name ifn receiver = ifscope ifn (receiver ++ "_msg_t")
107
108-- Name of the struct type for the method vtable
109intf_vtbl_type :: String -> String -> String -> String
110intf_vtbl_type ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv
111
112intf_vtbl_type_x :: String -> String -> String -> String
113intf_vtbl_type_x ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv ++ "_x"
114
115intf_selector_type :: String -> String -> String
116intf_selector_type ifn sender = ifscope ifn (sender ++ "_selector")
117
118-- Name of the struct types for the RPC call vtables
119rpc_seq_vtbl_type :: String -> String
120rpc_seq_vtbl_type ifn = ifscope ifn $ "thc_rpc_seq"
121
122rpc_fifo_vtbl_type :: String -> String
123rpc_fifo_vtbl_type ifn = ifscope ifn $ "thc_rpc_fifo"
124
125rpc_ooo_vtbl_type :: String -> String
126rpc_ooo_vtbl_type ifn = ifscope ifn $ "thc_rpc_ooo"
127
128rpc_seq_vtbl_type_x :: String -> String
129rpc_seq_vtbl_type_x ifn = ifscope ifn $ "thc_rpc_seq_x"
130
131rpc_fifo_vtbl_type_x :: String -> String
132rpc_fifo_vtbl_type_x ifn = ifscope ifn $ "thc_rpc_fifo_x"
133
134rpc_ooo_vtbl_type_x :: String -> String
135rpc_ooo_vtbl_type_x ifn = ifscope ifn $ "thc_rpc_ooo_x"
136
137-- Name of a function to initialize a client/server THC binding
138init_client_name :: String -> String
139init_client_name ifn = ifscope ifn $ "thc_init_client"
140
141init_service_name :: String -> String
142init_service_name ifn = ifscope ifn $ "thc_init_service"
143
144-- Type and name for the sequencer used for OOO RPC IDs
145ooo_rpc_seq_type = "thc_seq_t"
146ooo_rpc_seq_name = "ooo_rpc_seq"
147
148-- Type and name for the generic per-binding state
149thc_per_binding_state_struct = "thc_per_binding_state_t"
150thc_per_binding_state_name = "thc_per_binding"
151
152thc_binding_lock_name = "thc_binding_lock"
153
154-- Type and name for the generic per-receivable-message state
155thc_per_recv_state_struct = "thc_per_recv_t"
156thc_per_recv_state_name = "thc_per_recv"
157
158-- Type for the export_info / connect_info struct
159thc_export_info_struct_name ifn = ifscope ifn "thc_export_info"
160thc_export_info_t ifn = C.Struct $ thc_export_info_struct_name ifn
161thc_connect_info_struct_name ifn = ifscope ifn "thc_connect_info"
162thc_connect_info_t ifn = C.Struct $ thc_connect_info_struct_name ifn
163
164-- Names for the THC export/accept/connect functions
165thc_export_fn_name ifn = ifscope ifn "thc_export"
166thc_accept_fn_name ifn = ifscope ifn "thc_accept"
167thc_connect_fn_name ifn = ifscope ifn "thc_connect"
168thc_connect_by_name_fn_name ifn = ifscope ifn "thc_connect_by_name"
169
170------------------------------------------------------------------------
171-- Language mapping: Create the THC header file for the interface
172------------------------------------------------------------------------
173
174compile :: String -> String -> Interface -> String
175compile infile outfile interface =
176    unlines $ C.pp_unit $ intf_thc_header_file infile interface
177
178intf_thc_header_file :: String -> Interface -> C.Unit
179intf_thc_header_file infile interface@(Interface name _ _) =
180    let sym = "__" ++ name ++ "_THC_IF_H"
181    in
182      C.IfNDef sym ([ C.Define sym [] "1"] ++ (intf_thc_header_body infile interface)) []
183
184intf_thc_header_body :: String -> Interface -> [C.Unit]
185intf_thc_header_body infile interface@(Interface name descr decls) =
186    let (types, messages) = partitionTypesMessages decls
187    in [ BC.intf_preamble infile name descr,
188
189         C.IfDef "BARRELFISH" [ C.Include C.Local "thc/thcstubs.h",
190                                C.Include C.Local ("if/" ++ name ++ "_defs.h") ]
191                              [ C.Include C.Local "thcstubs.h",
192                                C.Include C.Local (name ++ ".h") ],
193         C.Blank,
194         C.MultiComment [ "Typedefs for binding structures" ],
195         C.Blank,
196         C.TypeDef (C.Struct $ intf_bind_type name "client") (intf_bind_type name "client"),
197         C.TypeDef (C.Struct $ intf_bind_type name "service") (intf_bind_type name "service"),
198
199         C.Blank,
200         C.MultiComment [ "Struct type for holding the args for each msg" ],
201         C.UnitList [ msg_argstruct name m | m <- messages ],
202         C.Blank,
203
204         C.MultiComment [ "Union type for all message arguments" ],
205         intf_union name messages,
206         C.Blank,
207
208         C.MultiComment [ "Enumerations for message numbers" ],
209         msg_enums msg_enum_name msg_enum_elem_name name messages,
210         msg_enums call_msg_enum_name call_msg_enum_elem_name name [ m | m <- messages, isForward m ],
211         msg_enums resp_msg_enum_name resp_msg_enum_elem_name name [ m | m <- messages, isBackward m ],
212         C.Blank,
213
214         C.Blank,
215         C.MultiComment [ "Signatures for individual send/receive operations" ],
216         C.Blank,
217         C.UnitList [ send_signature ClientSide "client" name m | m <- messages, isForward m ],
218         C.UnitList [ send_signature_x ClientSide "client" name m | m <- messages, isForward m ],
219         C.UnitList [ receive_signature ServerSide "service" name m | m <- messages, isForward m ],
220         C.UnitList [ receive_signature_x ServerSide "service" name m | m <- messages, isForward m ],
221         C.UnitList [ send_signature ServerSide "service" name m | m <- messages, isBackward m ],
222         C.UnitList [ send_signature_x ServerSide "service" name m | m <- messages, isBackward m ],
223         C.UnitList [ receive_signature ClientSide "client" name m | m <- messages, isBackward m ],
224         C.UnitList [ receive_signature_x ClientSide "client" name m | m <- messages, isBackward m ],
225         C.UnitList [ call_signature name m | m <- messages, isRPC m ],
226         C.UnitList [ call_signature_x name m | m <- messages, isRPC m ],
227         C.UnitList [ call_ooo_signature name m | m <- messages, isOOORPC m ],
228         C.UnitList [ call_ooo_signature_x name m | m <- messages, isOOORPC m ],
229
230         C.Blank,
231         C.MultiComment [ "VTables of send/receive operations" ],
232         C.Blank,
233         C.StructDecl (intf_vtbl_type name "client" "send_vtbl") [ intf_vtbl_op name "client" "send" m | m <- messages, isForward m] ,
234         C.StructDecl (intf_vtbl_type_x name "client" "send_vtbl") [ intf_vtbl_op_x name "client" "send" m | m <- messages, isForward m] ,
235         C.StructDecl (intf_vtbl_type name "service" "receive_vtbl") [ intf_vtbl_op name "service" "recv" m | m <- messages, isForward m] ,
236         C.StructDecl (intf_vtbl_type_x name "service" "receive_vtbl") [ intf_vtbl_op_x name "service" "recv" m | m <- messages, isForward m] ,
237         C.StructDecl (intf_selector_type name "service") [ intf_selector_op name "service" "receive_handler" m | m <- messages, isForward m] ,
238         C.StructDecl (intf_vtbl_type name "service" "send_vtbl") [ intf_vtbl_op name "service" "send" m | m <- messages, isBackward m] ,
239         C.StructDecl (intf_vtbl_type_x name "service" "send_vtbl") [ intf_vtbl_op_x name "service" "send" m | m <- messages, isBackward m] ,
240         C.StructDecl (intf_vtbl_type name "client" "receive_vtbl") [ intf_vtbl_op name "client" "recv" m | m <- messages, isBackward m] ,
241         C.StructDecl (intf_vtbl_type_x name "client" "receive_vtbl") [ intf_vtbl_op_x name "client" "recv" m | m <- messages, isBackward m] ,
242         C.StructDecl (intf_selector_type name "client") [ intf_selector_op name "client" "receive_handler" m | m <- messages, isBackward m] ,
243
244         C.Blank,
245         C.MultiComment [ "VTables of RPC operations" ],
246         C.Blank,
247         C.StructDecl (rpc_seq_vtbl_type name) [ rpc_seq_vtbl_op name m | m <- messages, isRPC m ],
248         C.StructDecl (rpc_seq_vtbl_type_x name) [ rpc_seq_vtbl_op_x name m | m <- messages, isRPC m ],
249         C.StructDecl (rpc_fifo_vtbl_type name) [ rpc_fifo_vtbl_op name m | m <- messages, isRPC m ],
250         C.StructDecl (rpc_fifo_vtbl_type_x name) [ rpc_fifo_vtbl_op_x name m | m <- messages, isRPC m ],
251         C.StructDecl (rpc_ooo_vtbl_type name) [ rpc_ooo_vtbl_op name m | m <- messages, isOOORPC m ],
252         C.StructDecl (rpc_ooo_vtbl_type_x name) [ rpc_ooo_vtbl_op_x name m | m <- messages, isOOORPC m ],
253
254         C.Blank,
255         C.MultiComment [ "Types for recv_any operations" ],
256         C.Blank,
257         C.UnitList [ receive_any_types name "client" ],
258         C.UnitList [ receive_any_types name "service" ],
259
260         C.Blank,
261         C.MultiComment [ "Binding structures" ],
262         C.Blank,
263         C.UnitList [ binding_struct ClientSide name [ m | m <- messages, isBackward m ] ],
264         C.UnitList [ binding_struct ServerSide name [ m | m <- messages, isForward m ] ],
265
266         C.Blank,
267         C.MultiComment [ "Initialize a THC binding over an IDC binding",
268                          "(defined in THC-stubs backend)" ],
269         C.Blank,
270         C.GVarDecl C.Extern C.NonConst
271            (C.Function C.NoScope (C.TypeName "errval_t") [
272                C.Param (C.Ptr $ C.TypeName $ intf_bind_type name "client") "thc",
273                C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_c2s",
274                C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_s2c"
275            ]) (init_client_name name) Nothing,
276         C.GVarDecl C.Extern C.NonConst
277            (C.Function C.NoScope (C.TypeName "errval_t") [
278                C.Param (C.Ptr $ C.TypeName $ intf_bind_type name "service") "thc",
279                C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_c2s",
280                C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_s2c"
281            ]) (init_service_name name) Nothing,
282
283         C.Blank,
284         C.MultiComment [ "THC helper functions for establishing connections" ],
285         C.StructDecl (thc_export_info_struct_name name) [
286            C.Param (C.TypeName "thc_sem_t") "export_cb_done_sem",
287            C.Param (C.TypeName "thc_sem_t") "connect_cb_done_sem",
288            C.Param (C.TypeName "thc_sem_t") "accept_call_present_sem",
289            C.Param (C.TypeName "thc_lock_t") "next_accept_lock",
290            C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b",
291            C.Param (C.TypeName "thc_lock_t") "info_lock",
292            C.Param (C.TypeName "errval_t") "err",
293            C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name",
294            C.Param (C.TypeName "iref_t") "iref",
295            C.Param (C.Ptr $ C.TypeName "iref_t") "iref_ptr"
296         ],
297         C.StructDecl (thc_connect_info_struct_name name) [
298            C.Param (C.TypeName "thc_sem_t") "bind_cb_done_sem",
299            C.Param (C.TypeName "errval_t") "err",
300            C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "b"
301         ],
302         C.GVarDecl C.Extern C.NonConst
303            (C.Function C.NoScope (C.TypeName "errval_t") [
304                C.Param (C.Ptr $ thc_export_info_t name) "info",
305                C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name",
306                C.Param (C.Ptr $ C.Struct "waitset") "ws",
307                C.Param (C.TypeName "idc_export_flags_t") "flags",
308                C.Param (C.Ptr $ C.TypeName "iref_t") "iref"
309            ]) (thc_export_fn_name name) Nothing,
310         C.GVarDecl C.Extern C.NonConst
311            (C.Function C.NoScope (C.TypeName "errval_t") [
312                C.Param (C.Ptr $ thc_export_info_t name) "info",
313                C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b"
314            ]) (thc_accept_fn_name name) Nothing,
315         C.GVarDecl C.Extern C.NonConst
316            (C.Function C.NoScope (C.TypeName "errval_t") [
317                C.Param (C.TypeName "iref_t") "iref",
318                C.Param (C.Ptr $ C.Struct "waitset") "ws",
319                C.Param (C.TypeName "idc_bind_flags_t") "flags",
320                C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b"
321            ]) (thc_connect_fn_name name) Nothing,
322         C.GVarDecl C.Extern C.NonConst
323            (C.Function C.NoScope (C.TypeName "errval_t") [
324                C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name",
325                C.Param (C.Ptr $ C.Struct "waitset") "ws",
326                C.Param (C.TypeName "idc_bind_flags_t") "flags",
327                C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b"
328            ]) (thc_connect_by_name_fn_name name) Nothing
329
330         ]
331
332isRPC :: MessageDef -> Bool
333isRPC (RPC _ _ _) = True
334isRPC _ = False
335
336isOOORPC :: MessageDef -> Bool
337isOOORPC (RPC _ ((RPCArgIn (Builtin UInt64) (Name "seq_in")):(RPCArgOut (Builtin UInt64) (Name "seq_out")):_) _) = True
338isOOORPC _ = False
339
340binding_struct :: Side -> String -> [MessageDef] -> C.Unit
341binding_struct side ifn messages =
342   let end = (case side of
343                ClientSide -> "client"
344                ServerSide -> "service")
345       nmessages = length messages
346       rpcparams ServerSide = []
347       rpcparams ClientSide = [C.Param (C.Struct $ rpc_seq_vtbl_type ifn) "call_seq",
348                               C.Param (C.Struct $ rpc_fifo_vtbl_type ifn) "call_fifo",
349                               C.Param (C.Struct $ rpc_ooo_vtbl_type ifn) "call",
350                               C.Param (C.Struct $ rpc_seq_vtbl_type_x ifn) "call_seq_x",
351                               C.Param (C.Struct $ rpc_fifo_vtbl_type_x ifn) "call_fifo_x",
352                               C.Param (C.Struct $ rpc_ooo_vtbl_type_x ifn) "call_x",
353                               C.Param (C.TypeName $ ooo_rpc_seq_type) ooo_rpc_seq_name
354                                ]
355   in
356    C.StructDecl (intf_bind_type ifn end) $ concat [
357        [C.Param (C.Struct $ thc_per_binding_state_struct) thc_per_binding_state_name],
358        [C.Param (C.Struct $ intf_vtbl_type ifn end "send_vtbl") "send"],
359        [C.Param (C.Struct $ intf_vtbl_type_x ifn end "send_vtbl") "send_x"],
360        [C.Param (C.Struct $ intf_vtbl_type ifn end "receive_vtbl") "recv"],
361        [C.Param (C.Struct $ intf_vtbl_type_x ifn end "receive_vtbl") "recv_x"],
362        [C.Param (C.TypeName $ rx_any_sig_type ifn end) "recv_any"],
363        [C.Param (C.TypeName $ rx_any_sig_type_x ifn end) "recv_any_x"],
364        rpcparams side,
365        [C.Param (C.Array (fromIntegral nmessages) $ C.Struct $ thc_per_recv_state_struct) thc_per_recv_state_name],
366        [C.Param (C.Ptr $ C.TypeName "void") "_c2s_st"],
367        [C.Param (C.Ptr $ C.TypeName "void") "_s2c_st"]
368    ]
369
370receive_any_types :: String -> String -> C.Unit
371receive_any_types ifn receiver =
372   let
373    params = [ C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn receiver) intf_bind_var,
374               C.Param (C.Ptr $ C.Struct $ rx_any_struct_name ifn receiver) "msg",
375               C.Param (C.Struct $ intf_selector_type ifn receiver) "ops" ]
376    rx_t_name = rx_any_sig_type ifn receiver
377    rx_t_name_x = rx_any_sig_type_x ifn receiver
378   in
379    C.UnitList [
380      C.StructDecl (rx_any_struct_name ifn receiver)
381        [ C.Param (C.Enum $ msg_enum_name ifn) "msg",
382          C.Param (C.Union $ binding_arg_union_type ifn ) "args"
383          ],
384      C.TypeDef (C.Struct $ rx_any_struct_name ifn receiver) (rx_any_type_name ifn receiver),
385      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) ("(*" ++ rx_t_name ++ ")"),
386      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) ("(*" ++ rx_t_name_x ++ ")")
387     ]
388
389rpc_seq_vtbl_op :: String -> MessageDef -> C.Param
390rpc_seq_vtbl_op ifn m@(RPC n _ _) =
391    C.Param (C.TypeName $ call_sig_type ifn m) n
392
393rpc_fifo_vtbl_op :: String -> MessageDef -> C.Param
394rpc_fifo_vtbl_op ifn m@(RPC n _ _) =
395    C.Param (C.TypeName $ call_sig_type ifn m) n
396
397rpc_ooo_vtbl_op :: String -> MessageDef -> C.Param
398rpc_ooo_vtbl_op ifn m@(RPC n _ _) =
399    C.Param (C.TypeName $ call_ooo_sig_type ifn m) n
400
401rpc_seq_vtbl_op_x :: String -> MessageDef -> C.Param
402rpc_seq_vtbl_op_x ifn m@(RPC n _ _) =
403    C.Param (C.TypeName $ call_sig_type_x ifn m) n
404
405rpc_fifo_vtbl_op_x :: String -> MessageDef -> C.Param
406rpc_fifo_vtbl_op_x ifn m@(RPC n _ _) =
407    C.Param (C.TypeName $ call_sig_type_x ifn m) n
408
409rpc_ooo_vtbl_op_x :: String -> MessageDef -> C.Param
410rpc_ooo_vtbl_op_x ifn m@(RPC n _ _) =
411    C.Param (C.TypeName $ call_ooo_sig_type_x ifn m) n
412
413intf_vtbl_op :: String -> String -> String -> MessageDef -> C.Param
414intf_vtbl_op ifn sender sendrecv m =
415    C.Param (C.TypeName $ msg_sig_type ifn sender sendrecv m) (BC.msg_name m)
416
417intf_vtbl_op_x :: String -> String -> String -> MessageDef -> C.Param
418intf_vtbl_op_x ifn sender sendrecv m =
419    C.Param (C.TypeName $ msg_sig_type_x ifn sender sendrecv m) (BC.msg_name m)
420
421intf_selector_op :: String -> String -> String -> MessageDef -> C.Param
422intf_selector_op ifn sender sendrecv m =
423    C.Param (C.TypeName "int") (BC.msg_name m)
424
425-- Should do this properly rather than string munging.
426fnptr :: String -> String
427fnptr s = "(*" ++ s ++ ")"
428
429call_signature :: String -> MessageDef -> C.Unit
430call_signature ifname m@(RPC s args _) =
431    let name = call_sig_type ifname m
432        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
433                  intf_bind_var
434        params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- args ]
435    in
436      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
437
438call_signature_x :: String -> MessageDef -> C.Unit
439call_signature_x ifname m@(RPC s args _) =
440    let name = call_sig_type_x ifname m
441        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
442                  intf_bind_var
443        params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- args ]
444    in
445      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
446
447call_ooo_signature :: String -> MessageDef -> C.Unit
448call_ooo_signature ifname m@(RPC s args _) =
449    let name = call_ooo_sig_type ifname m
450        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
451                  intf_bind_var
452        params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- (tail (tail args)) ]
453    in
454      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
455
456call_ooo_signature_x :: String -> MessageDef -> C.Unit
457call_ooo_signature_x ifname m@(RPC s args _) =
458    let name = call_ooo_sig_type_x ifname m
459        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client")
460                  intf_bind_var
461        params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- (tail (tail args)) ]
462    in
463      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
464
465send_signature :: Side -> String -> String -> MessageDef -> C.Unit
466
467send_signature side sender ifname m@(Message dir _ args _) =
468    let name = msg_sig_type ifname sender "send" m
469        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
470                  intf_bind_var
471        params = [ binding ] ++ concat [ BC.msg_argdecl BC.TX ifname a | a <- args ]
472    in
473      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
474
475send_signature side sender ifname m@(RPC s args _) =
476    let name = msg_sig_type ifname sender "send" m
477        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
478                  intf_bind_var
479        params = [ binding ] ++ concat [ rpc_send_argdecl side ifname a | a <- args ]
480    in
481      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
482
483receive_signature side receiver ifname m@(Message dir _ args _) =
484    let name = msg_sig_type ifname receiver "recv" m
485        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
486                  intf_bind_var
487        params = [ binding ] ++ concat [ receive_msg_argdecl ifname a | a <- args ]
488    in
489      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
490
491receive_signature side receiver ifname m@(RPC s args _) =
492    let name = msg_sig_type ifname receiver "recv" m
493        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
494                  intf_bind_var
495        params = [ binding ] ++ concat [ rpc_receive_argdecl side ifname a | a <- args ]
496    in
497      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
498
499send_signature_x side sender ifname m@(Message dir _ args _) =
500    let name = msg_sig_type_x ifname sender "send" m
501        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
502                  intf_bind_var
503        params = [ binding ] ++ concat [ BC.msg_argdecl BC.TX ifname a | a <- args ]
504    in
505      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
506
507send_signature_x side sender ifname m@(RPC s args _) =
508    let name = msg_sig_type_x ifname sender "send" m
509        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender)
510                  intf_bind_var
511        params = [ binding ] ++ concat [ rpc_send_argdecl side ifname a | a <- args ]
512    in
513      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
514
515receive_signature_x side receiver ifname m@(Message dir _ args _) =
516    let name = msg_sig_type_x ifname receiver "recv" m
517        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
518                  intf_bind_var
519        params = [ binding ] ++ concat [ receive_msg_argdecl ifname a | a <- args ]
520    in
521      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
522
523receive_signature_x side receiver ifname m@(RPC s args _) =
524    let name = msg_sig_type_x ifname receiver "recv" m
525        binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver)
526                  intf_bind_var
527        params = [ binding ] ++ concat [ rpc_receive_argdecl side ifname a | a <- args ]
528    in
529      C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name
530
531rpc_call_argdecl :: String -> RPCArgument -> [C.Param]
532rpc_call_argdecl ifn (RPCArgIn tr v) = BC.msg_argdecl BC.TX ifn (Arg tr v)
533rpc_call_argdecl ifn (RPCArgOut tr v) = receive_msg_argdecl ifn (Arg tr v)
534
535rpc_send_argdecl :: Side -> String -> RPCArgument -> [C.Param]
536rpc_send_argdecl ClientSide ifn (RPCArgIn tr v) = BC.msg_argdecl BC.TX ifn (Arg tr v)
537rpc_send_argdecl ClientSide ifn (RPCArgOut  _ _) = []
538rpc_send_argdecl ServerSide ifn (RPCArgIn _ _) = []
539rpc_send_argdecl ServerSide ifn (RPCArgOut tr v)  = BC.msg_argdecl BC.TX ifn (Arg tr v)
540
541receive_msg_argdecl :: String -> MessageArgument -> [C.Param]
542receive_msg_argdecl ifn (Arg tr (Name n)) =
543    [ C.Param (C.Ptr $ BC.type_c_type ifn tr) n ]
544receive_msg_argdecl ifn (Arg tr (StringArray n l)) = 
545    [ C.Param (BC.type_c_type ifn tr) n ]
546receive_msg_argdecl ifn (Arg tr (DynamicArray n l _)) =
547    [ C.Param (C.Ptr $ BC.type_c_type ifn tr) n, 
548      C.Param (C.Ptr $ BC.type_c_type ifn size) l ]
549
550rpc_receive_argdecl :: Side -> String -> RPCArgument -> [C.Param]
551rpc_receive_argdecl ClientSide ifn (RPCArgOut tr v) = receive_msg_argdecl ifn (Arg tr v)
552rpc_receive_argdecl ClientSide ifn (RPCArgIn  _ _) = []
553rpc_receive_argdecl ServerSide ifn (RPCArgOut _ _) = []
554rpc_receive_argdecl ServerSide ifn (RPCArgIn tr v)  = receive_msg_argdecl ifn (Arg tr v)
555
556msg_enums :: (String -> String) -> (String -> String -> String) -> String -> [MessageDef] -> C.Unit
557msg_enums enum element ifname msgs =
558    C.EnumDecl (enum ifname)
559         ([ C.EnumItem (element ifname n) Nothing
560                | m@(Message _ n _ _) <- msgs ]
561          ++
562          [ C.EnumItem (element ifname n) Nothing
563                | m@(RPC n _ _) <- msgs ]
564         )
565
566--
567-- Generate a struct to hold the arguments of a message while it's being sent.
568--
569msg_argstruct :: String -> MessageDef -> C.Unit
570msg_argstruct ifname m@(Message _ n [] _) = C.NoOp
571msg_argstruct ifname m@(Message _ n args _) =
572    let tn = msg_argstruct_name ifname n
573    in
574      C.StructDecl tn (concat [ BC.msg_argstructdecl BC.RX ifname [] a | a <- args ])
575msg_argstruct ifname m@(RPC n args _) =
576    C.UnitList [
577      C.StructDecl (rpc_argstruct_name ifname n "in")
578           (concat [ rpc_argdecl ClientSide ifname a | a <- args ]),
579      C.StructDecl (rpc_argstruct_name ifname n "out")
580           (concat [ rpc_argdecl ServerSide ifname a | a <- args ]),
581      C.UnionDecl (rpc_union_name ifname n) [
582        C.Param (C.Struct $ rpc_argstruct_name ifname n "in") "in",
583        C.Param (C.Struct $ rpc_argstruct_name ifname n "out") "out"
584       ]
585     ]
586
587--
588-- Generate a union of all the above
589--
590intf_union :: String -> [MessageDef] -> C.Unit
591intf_union ifn msgs =
592    C.UnionDecl (binding_arg_union_type ifn)
593         ([ C.Param (C.Struct $ msg_argstruct_name ifn n) n
594            | m@(Message _ n a _) <- msgs, 0 /= length a ]
595          ++
596          [ C.Param (C.Union $ rpc_union_name ifn n) n
597            | m@(RPC n a _) <- msgs, 0 /= length a ])
598
599rpc_argdecl :: Side -> String -> RPCArgument -> [C.Param]
600rpc_argdecl ClientSide ifn (RPCArgIn tr v) = BC.msg_argstructdecl BC.RX ifn [] (Arg tr v)
601rpc_argdecl ClientSide ifn (RPCArgOut _ _) = []
602rpc_argdecl ServerSide ifn (RPCArgOut tr v) = BC.msg_argstructdecl BC.RX ifn [] (Arg tr v)
603rpc_argdecl ServerSide ifn (RPCArgIn _ _) = []
604