1{-
2   GHBackend: Flounder stub generator for generic header files
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 GHBackend where
15
16import Data.List
17import Data.Char
18
19import qualified CAbsSyntax as C
20import Syntax
21import qualified Backend
22import BackendCommon
23
24accept_fn_name n = ifscope n "accept"
25connect_fn_name n = ifscope n "connect"
26
27export_fn_name n = ifscope n "export"
28bind_fn_name n = ifscope n "bind"
29
30connect_handlers_fn_name n = ifscope n "connect_handlers"
31disconnect_handlers_fn_name n = ifscope n "disconnect_handlers"
32
33-- Name of the init function
34rpc_init_fn_name :: String -> String
35rpc_init_fn_name ifn = ifscope ifn "rpc_client_init"
36
37rpc_rx_vtbl_type ifn = ifscope ifn "rpc_rx_vtbl"
38rpc_tx_vtbl_type ifn = ifscope ifn "rpc_tx_vtbl"
39local_rpc_tx_vtbl_type ifn = ifscope ifn "local_rpc_tx_vtbl"
40
41------------------------------------------------------------------------
42-- Language mapping: Create the generic header file for the interface
43------------------------------------------------------------------------
44
45compile :: String -> String -> Interface -> String
46compile infile outfile interface =
47    unlines $ C.pp_unit $ intf_header_file infile interface
48
49header_file :: String -> Interface -> [C.Unit] -> C.Unit
50header_file infile interface@(Interface name _ _) body =
51    let sym = "__" ++ name ++ "_IF_H"
52    in
53      C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
54
55intf_header_file :: String -> Interface -> C.Unit
56intf_header_file infile intf =
57    header_file infile intf (intf_header_body infile intf)
58
59intf_header_body :: String -> Interface -> [C.Unit]
60intf_header_body infile interface@(Interface name descr decls) =
61    let
62        (types, messagedecls) = Backend.partitionTypesMessages decls
63        messages = rpcs_to_msgs messagedecls
64        rpcs = [m | m@(RPC _ _ _) <- messagedecls]
65    in
66      [ intf_preamble infile name descr,
67        C.Blank,
68
69        C.Include C.Standard "flounder/flounder.h",
70        C.Include C.Standard "flounder/flounder_support.h",
71        C.Blank,
72
73        C.MultiComment [ "Concrete type definitions" ],
74        C.UnitList $ define_types name types,
75        C.Blank,
76
77        C.MultiComment [ "Forward declaration of binding type" ],
78        C.StructForwardDecl (intf_bind_type name),
79        C.Blank,
80
81        C.MultiComment [ "Contination (callback) and control function types" ],
82        intf_bind_cont_fn name,
83        can_send_fn_typedef name,
84        register_send_fn_typedef name,
85        change_waitset_fn_typedef name,
86        control_fn_typedef name,
87        error_handler_fn_typedef name,
88        receive_next_fn_typedef name,
89        get_receiving_chanstate_fn_typedef name,
90        C.Blank,
91
92        C.MultiComment [ "Enumeration for message numbers" ],
93        msg_enums name messages,
94        C.Blank,
95
96        C.MultiComment [ "Message type signatures (transmit)" ],
97        C.UnitList [ msg_signature TX name m | m <- messages ],
98        C.Blank,
99
100        C.MultiComment [ "Message type signatures (receive)" ],
101        C.UnitList [ msg_signature RX name m | m <- messages ],
102        C.Blank,
103
104        C.MultiComment [ "RPC RX function signatures" ],
105        C.UnitList [ msg_signature_generic RX name types (binding_param name) m
106                    | m <- rpcs ],
107        C.Blank,
108
109        C.MultiComment [ "RPC TX Function signatures" ],
110        C.UnitList [ msg_signature_generic TX name types (binding_param name) m
111                    | m <- rpcs ],
112        C.Blank,
113
114        C.MultiComment [ "Struct type for holding the RX args for each msg" ],
115        C.UnitList [ msg_argstruct RX name types m | m <- messages ],
116        C.Blank,
117
118        C.MultiComment [ "Struct type for holding the TX args for each msg" ],
119        C.UnitList [ msg_argstruct TX name types m | m <- messages ],
120        C.Blank,
121
122        C.MultiComment [ "Union type for all message arguments" ],
123        intf_union RX name messages,
124        C.Blank,
125
126        C.MultiComment [ "Union type for all message arguments" ],
127        intf_union TX name messages,
128        C.Blank,
129
130        C.MultiComment [ "Maximum Transfer Size" ],
131        msg_arg_sizes name types messages,
132        msg_arg_size name types messages,
133        C.Blank,
134
135        C.MultiComment [ "VTable struct definition for the interface (transmit)" ],
136        intf_vtbl name TX messages,
137        C.Blank,
138
139        C.MultiComment [ "VTable struct definition for the interface (receive)" ],
140        intf_vtbl name RX messages,
141        C.Blank,
142
143        C.MultiComment [ "VTable struct definition for the rpc interface (receive)" ],
144        rpc_rx_vtbl_decl name rpcs,
145        C.Blank,
146
147        C.MultiComment [ "VTable struct definition for the rpc interface (transmit)" ],
148        rpc_tx_vtbl_decl name rpcs,
149        C.Blank,
150        
151        C.MultiComment [ "Incoming connect callback type" ],
152        connect_callback_fn name,
153        C.Blank,
154
155        C.MultiComment [ "Export state struct" ],
156        export_struct name,
157        C.Blank,
158
159        C.MultiComment [ "Export function" ],
160        export_function name,
161        C.Blank,
162
163        C.MultiComment [ "The message buffer structure (for accept/connect)" ],
164        frameinfo_struct name messages,
165        C.Blank,
166
167        C.MultiComment [ "Accept function over already shared frame" ],
168        accept_function name,
169        C.Blank,
170
171        C.MultiComment [ "The Binding structure" ],
172        binding_struct name messages,
173        C.Blank,
174
175        C.MultiComment [ "Generic bind function" ],
176        bind_function name,
177        C.Blank,
178
179        C.MultiComment [ "Generic connect function over already shared frame" ],
180        connect_function name,
181        C.Blank,
182
183        C.MultiComment [ "Send wrappers" ],
184        C.UnitList [ tx_wrapper name m | m <- messages ],
185        C.Blank,
186
187        C.MultiComment [ "Backend-specific includes" ],
188        C.UnitList $ backend_includes name,
189
190        C.MultiComment [ "Function to initialise an RPC client" ],
191        rpc_init_fn_proto name,
192        
193        C.MultiComment [ "And we're done" ]
194      ]
195
196--
197-- Generate an enumeration for each message type, to use as procedure numbers.
198--
199msg_enums :: String -> [MessageDef] -> C.Unit
200msg_enums ifname msgs
201    = C.EnumDecl (msg_enum_name ifname)
202        ([C.EnumItem (msg_enum_elem_name ifname "__dummy") (Just $ C.NumConstant 0)] ++
203         [C.EnumItem (msg_enum_elem_name ifname "__bind") (Just $ C.NumConstant 1)] ++
204         [C.EnumItem (msg_enum_elem_name ifname "__bind_reply") (Just $ C.NumConstant 2)] ++
205         [C.EnumItem (msg_enum_elem_name ifname (msg_name m)) (Just $ C.NumConstant i)
206            | (m, i) <- zip msgs [3..]])
207
208--
209-- Generate type definitions for each message signature
210--
211msg_signature_generic :: Direction -> String -> [TypeDef] -> C.Param -> MessageDef -> C.Unit
212msg_signature_generic dirn ifname typedefs firstparam m =
213    C.TypeDef (C.Function C.NoScope (return_type dirn m) params) name
214  where
215    name = msg_sig_type ifname m dirn
216    continuation = C.Param (C.Struct "event_closure") intf_cont_var
217    -- need a continuation only for non-RPC TX
218    opt_continuation = case dirn of
219        TX -> case m of
220            RPC _ _ _ -> []
221            otherwise -> [ continuation ]
222        RX -> []
223    params = [ firstparam ] ++ opt_continuation ++ concat payload
224    payload = case m of
225        Message _ _ args _ -> [ msg_argdecl dirn ifname a | a <- args ]
226        RPC s args _       -> [ rpc_argdecl2 dirn ifname typedefs a | a <- args ]
227    return_type RX m@(Message _ _ _ _) = C.TypeName "void"
228    return_type _ _ = C.TypeName "errval_t"
229
230msg_signature :: Direction -> String -> MessageDef -> C.Unit
231msg_signature dir ifn = msg_signature_generic dir ifn [] (binding_param ifn)
232
233rpc_rx_vtbl_decl :: String -> [MessageDef] -> C.Unit
234rpc_rx_vtbl_decl n ml =
235    C.StructDecl (rpc_rx_vtbl_type n) [ param n m | m <- ml ]
236    where
237        param ifn m = C.Param (C.Ptr $ C.TypeName $ msg_sig_type ifn m RX) ((msg_name m) ++ "_call")
238
239rpc_tx_vtbl_decl :: String -> [MessageDef] -> C.Unit
240rpc_tx_vtbl_decl n ml =
241    C.StructDecl (rpc_tx_vtbl_type n) [ intf_vtbl_param n m TX | m <- ml ]
242
243
244--
245-- Get the maximum size of the arguments
246--
247
248msg_arg_size :: String -> [TypeDef] -> [MessageDef] -> C.Unit
249msg_arg_size ifname typedefs messages = C.Define (msg_arg_size_name ifname) []
250                 (C.pp_expr (C.SizeOfT $ C.Union $ binding_arg_union_type RX ifname))
251
252msg_arg_sizes :: String -> [TypeDef] -> [MessageDef] -> C.Unit
253msg_arg_sizes ifname typedefs messages =
254    C.UnitList [ C.UnitList $ define_msg_arg_size ifname m | m <- messages ]
255
256-- extracts the size of the arguemnts of a message
257define_msg_size :: String -> String-> MessageArgument -> C.Unit
258define_msg_size ifn fn (Arg tr (Name an)) = C.NoOp
259define_msg_size ifn fn (Arg tr (StringArray an maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen)
260define_msg_size ifn fn (Arg tr (DynamicArray an len maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen)
261
262
263-- extracts the size of the arguemnts of an RPC (out)
264define_rpc_size :: String -> String-> RPCArgument -> C.Unit
265define_rpc_size ifn fn (RPCArgOut tr (Name an)) = C.NoOp
266define_rpc_size ifn fn (RPCArgIn _ _) = C.NoOp
267define_rpc_size ifn fn (RPCArgOut tr (StringArray an maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen)
268define_rpc_size ifn fn (RPCArgOut tr (DynamicArray an len maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen)
269
270-- extract the size of arguemnts
271define_msg_arg_size :: String-> MessageDef -> [C.Unit]
272define_msg_arg_size ifn (RPC n [] _) = []
273define_msg_arg_size ifn (RPC n args _) = [define_rpc_size ifn n arg | arg <- args]
274define_msg_arg_size ifn (Message mtype n [] _) = []
275define_msg_arg_size ifn (Message mtype n args _) = [define_msg_size ifn n arg | arg <- args]
276
277
278
279--
280-- Generate a struct to hold the arguments of a message while it's being sent.
281--
282msg_argstruct :: Direction -> String -> [TypeDef] -> MessageDef -> C.Unit
283msg_argstruct dir ifname typedefs m@(RPC n args _) =
284    C.StructDecl (msg_argstruct_name dir ifname n)
285                    (concat [ rpc_argdecl TX ifname a | a <- args ])
286msg_argstruct dir ifname typedefs m@(Message _ n [] _) = C.NoOp
287msg_argstruct dir ifname typedefs m@(Message _ n args _) =
288              C.StructDecl (msg_argstruct_name dir ifname n)
289                    (concat [ msg_argstructdecl dir ifname typedefs a | a <- args ])
290--
291-- Generate a union of all the above
292--
293intf_union :: Direction -> String -> [MessageDef] -> C.Unit
294intf_union dir ifn msgs =
295    C.UnionDecl (binding_arg_union_type dir ifn)
296         ([ C.Param (C.Struct $ msg_argstruct_name dir ifn n) n
297            | m@(Message _ n a _) <- msgs, 0 /= length a ]
298          ++
299          [ C.Param (C.Struct $ msg_argstruct_name dir ifn n) n
300            | m@(RPC n a _) <- msgs, 0 /= length a ]
301         )
302
303--
304-- Generate a struct defn for a vtable for the interface
305--
306intf_vtbl :: String -> Direction -> [MessageDef] -> C.Unit
307intf_vtbl n d ml =
308    C.StructDecl (intf_vtbl_type n d) [ intf_vtbl_param n m d | m <- ml ]
309
310intf_vtbl_param :: String -> MessageDef -> Direction ->  C.Param
311intf_vtbl_param ifn m d = C.Param (C.Ptr $ C.TypeName $ msg_sig_type ifn m d) (msg_name m)
312
313--
314-- Generate the binding structure
315--
316binding_struct :: String -> [MessageDef] -> C.Unit
317binding_struct n ml = C.StructDecl (intf_bind_type n) fields
318  where
319    fields = [
320        C.ParamComment "Arbitrary user state pointer",
321        C.Param (C.Ptr C.Void) "st",
322        C.ParamBlank,
323
324        C.ParamComment "Waitset used for receive handlers",
325        C.Param (C.Ptr $ C.Struct "waitset") "waitset",
326        C.ParamBlank,
327
328        C.ParamComment "Mutex for the use of user code.",
329        C.ParamComment "Must be held before any operation where there is a possibility of",
330        C.ParamComment "concurrent access to the same binding (eg. multiple threads, or",
331        C.ParamComment "asynchronous event handlers that use the same binding object).",
332        C.Param (C.Struct "event_mutex") "mutex",
333        C.ParamBlank,
334
335        C.ParamComment "returns true iff a message could currently be accepted by the binding",
336        C.Param (C.Ptr $ C.TypeName $ can_send_fn_type n) "can_send",
337        C.ParamBlank,
338
339        C.ParamComment "register an event for when a message is likely to be able to be sent",
340        C.Param (C.Ptr $ C.TypeName $ register_send_fn_type n) "register_send",
341        C.ParamBlank,
342
343        C.ParamComment "change the waitset used by a binding",
344        C.Param (C.Ptr $ C.TypeName $ change_waitset_fn_type n) "change_waitset",
345        C.ParamBlank,
346
347        C.ParamComment "perform control operations",
348        C.Param (C.Ptr $ C.TypeName $ control_fn_type n) "control",
349        C.ParamBlank,
350
351        C.ParamComment "error handler for any async errors associated with this binding",
352        C.ParamComment "must be filled-in by user",
353        C.Param (C.Ptr $ C.TypeName $ error_handler_fn_type n) "error_handler",
354        C.ParamBlank,
355
356        C.ParamComment "receive next message",
357        C.Param (C.Ptr $ C.TypeName $ receive_next_fn_type n) "receive_next",
358        C.ParamBlank,
359
360        C.ParamComment "get receiving chanstate",
361        C.Param (C.Ptr $ C.TypeName $ get_receiving_chanstate_fn_type n) "get_receiving_chanstate",
362        C.ParamBlank,
363
364        C.ParamComment "Message send functions (filled in by binding)",
365        C.Param (C.Struct $ intf_vtbl_type n TX) "tx_vtbl",
366        C.ParamBlank,
367
368        C.ParamComment "Incoming message handlers, direct (filled in by user)",
369        C.Param (C.Struct $ intf_vtbl_type n RX) "rx_vtbl",
370        C.ParamBlank,
371
372        C.ParamComment "Incoming message handlers, indirect (filled in by user)",
373        C.Param (C.Struct $ intf_vtbl_type n RX) "message_rx_vtbl",
374        C.ParamBlank,
375
376        C.ParamComment "Incoming message rpc handlers (filled in by user)",
377        C.Param (C.Struct $ rpc_rx_vtbl_type n) "rpc_rx_vtbl",
378        C.ParamBlank,
379
380        C.ParamComment "RPC send functions (filled in by binding)",
381        C.Param (C.Struct $ rpc_tx_vtbl_type n) "rpc_tx_vtbl",
382        C.ParamBlank,
383
384        C.ParamComment "Message channels",
385        C.Param (C.Array (toInteger ((length ml) + 3)) (C.Struct "waitset_chanstate")) "message_chanstate",
386
387        C.ParamComment "Private state belonging to the binding implementation",
388        C.Param (C.Union $ binding_arg_union_type TX n) "tx_union",
389        C.Param (C.Union $ binding_arg_union_type RX n) "rx_union",
390        C.Param (C.Struct "waitset_chanstate") "register_chanstate",
391        C.Param (C.Struct "waitset_chanstate") "tx_cont_chanstate",
392        C.Param (C.Enum $ msg_enum_name n) "tx_msgnum",
393        C.Param (C.Enum $ msg_enum_name n) "rx_msgnum",
394        C.Param (C.TypeName "int") "tx_msg_fragment",
395        C.Param (C.TypeName "int") "rx_msg_fragment",
396        C.Param (C.TypeName "size_t") "tx_str_pos",
397        C.Param (C.TypeName "size_t") "rx_str_pos",
398        C.Param (C.TypeName "size_t") "tx_str_len",
399        C.Param (C.TypeName "size_t") "rx_str_len",
400        C.Param (C.Struct "event_queue_node") "event_qnode",
401        C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) "bind_cont",
402        C.Param (C.TypeName "uint32_t") "incoming_token",
403        C.Param (C.TypeName "uint32_t") "outgoing_token",
404        C.Param (C.Struct "thread_mutex") "rxtx_mutex",
405        C.Param (C.Struct "thread_mutex") "send_mutex",
406        C.Param (C.TypeName "errval_t") "error",
407        C.Param (C.Ptr $ C.Struct $ intf_bind_type n) "local_binding"
408        ]
409
410--
411-- Generate the binding structure
412--
413frameinfo_struct :: String -> [MessageDef] -> C.Unit
414frameinfo_struct n ml = C.StructDecl (intf_frameinfo_type n) fields
415  where
416    fields = [
417        C.ParamComment "Physical address of send buffer",
418        C.Param (C.TypeName "lpaddr_t") "sendbase",
419        C.ParamBlank,
420        C.ParamComment "Pointer to incoming message buffer",
421        C.Param (C.Ptr C.Void) "inbuf",
422        C.ParamBlank,
423        C.ParamComment "Size of the incoming buffer in bytes",
424        C.Param (C.TypeName "size_t") "inbufsize",
425        C.ParamBlank,
426        C.ParamComment "Pointer to outgoing message buffer",
427        C.Param (C.Ptr C.Void) "outbuf",
428        C.ParamBlank,
429        C.ParamComment "Size of the outgoing buffer in bytes",
430        C.Param (C.TypeName "size_t") "outbufsize",
431        C.ParamBlank]
432
433
434
435--
436-- Generate prototypes for export.
437--
438
439connect_callback_fn :: String -> C.Unit
440connect_callback_fn n =
441    C.TypeDef
442         (C.Function C.NoScope (C.TypeName "errval_t") params)
443         (connect_callback_name n)
444    where
445          params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
446                     C.Param (C.Ptr $ C.Struct $ intf_bind_type n) "binding" ]
447
448export_struct :: String -> C.Unit
449export_struct n = C.StructDecl (export_type n) fields
450  where
451    fields = [
452        C.Param (C.Struct "idc_export") "common",
453        C.Param (C.Ptr $ C.TypeName $ connect_callback_name n) "connect_cb",
454        C.Param (C.Ptr $ C.Struct "waitset") "waitset",
455        C.Param (C.Ptr $ C.Void) "st"]
456
457export_function :: String -> C.Unit
458export_function n =
459    C.GVarDecl C.Extern C.NonConst
460         (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
461    where
462      name = export_fn_name n
463      params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
464                 C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb",
465                 C.Param (C.Ptr $ C.TypeName $ connect_callback_name n) "connect_cb",
466                 C.Param (C.Ptr $ C.Struct "waitset") "ws",
467                 C.Param (C.TypeName "idc_export_flags_t") "flags"]
468
469intf_bind_cont_fn :: String -> C.Unit
470intf_bind_cont_fn n =
471    C.TypeDef
472         (C.Function C.NoScope (C.TypeName "void") params)
473         (intf_bind_cont_type n)
474    where
475      params = [ C.Param (C.Ptr $ C.TypeName "void") "st",
476                 C.Param (C.TypeName "errval_t") "err",
477                 binding_param n ]
478
479can_send_fn_typedef :: String -> C.Unit
480can_send_fn_typedef n =
481    C.TypeDef
482         (C.Function C.NoScope (C.TypeName "bool") params)
483         (can_send_fn_type n)
484    where
485      params = [ binding_param n ]
486
487register_send_fn_typedef :: String -> C.Unit
488register_send_fn_typedef n =
489    C.TypeDef
490         (C.Function C.NoScope (C.TypeName "errval_t") params)
491         (register_send_fn_type n)
492    where
493      params = [ binding_param n,
494                 C.Param (C.Ptr $ C.Struct "waitset") "ws",
495                 C.Param (C.Struct "event_closure") intf_cont_var ]
496
497change_waitset_fn_typedef :: String -> C.Unit
498change_waitset_fn_typedef n =
499    C.TypeDef
500         (C.Function C.NoScope (C.TypeName "errval_t") params)
501         (change_waitset_fn_type n)
502    where
503      params = [ binding_param n,
504                 C.Param (C.Ptr $ C.Struct "waitset") "ws" ]
505
506control_fn_typedef :: String -> C.Unit
507control_fn_typedef n =
508    C.TypeDef
509         (C.Function C.NoScope (C.TypeName "errval_t") params)
510         (control_fn_type n)
511    where
512      params = [ binding_param n,
513                  C.Param (C.TypeName "idc_control_t") "control" ]
514
515error_handler_fn_typedef :: String -> C.Unit
516error_handler_fn_typedef n =
517    C.TypeDef
518         (C.Function C.NoScope C.Void params)
519         (error_handler_fn_type n)
520    where
521      params = [ binding_param n,
522                 C.Param (C.TypeName "errval_t") "err" ]
523
524receive_next_fn_typedef :: String -> C.Unit
525receive_next_fn_typedef n =
526    C.TypeDef
527        (C.Function C.NoScope (C.TypeName "errval_t") params)
528        (receive_next_fn_type n)
529    where
530        params = [binding_param n]
531
532get_receiving_chanstate_fn_typedef :: String -> C.Unit
533get_receiving_chanstate_fn_typedef n =
534    C.TypeDef
535        (C.Function C.NoScope (C.Ptr $ C.Struct "waitset_chanstate") params)
536        (get_receiving_chanstate_fn_type n)
537    where
538        params = [binding_param n]
539
540bind_function :: String -> C.Unit
541bind_function n =
542    C.GVarDecl C.Extern C.NonConst
543         (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
544    where
545      name = bind_fn_name n
546      params = [ C.Param (C.TypeName "iref_t") "i",
547                 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
548                 C.Param (C.Ptr $ C.TypeName "void") "st",
549                 C.Param (C.Ptr $ C.Struct "waitset") "waitset",
550                 C.Param (C.TypeName "idc_bind_flags_t") "flags" ]
551
552-- Function for accepting new flounder connections over a already frame
553accept_function :: String -> C.Unit
554accept_function n =
555    C.GVarDecl C.Extern C.NonConst
556         (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
557    where
558      name = accept_fn_name n
559      params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var,
560                 C.Param (C.Ptr $ C.TypeName "void") "st",
561                 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
562                 C.Param (C.Ptr $ C.Struct "waitset") "ws",
563                 C.Param (C.TypeName "idc_export_flags_t") "flags"]
564
565connect_function :: String -> C.Unit
566connect_function n =
567    C.GVarDecl C.Extern C.NonConst
568         (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing
569    where
570      name = connect_fn_name n
571      params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var,
572                 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var,
573                 C.Param (C.Ptr $ C.TypeName "void") "st",
574                 C.Param (C.Ptr $ C.Struct "waitset") "ws",
575                 C.Param (C.TypeName "idc_bind_flags_t") "flags" ]
576
577rpc_init_fn_proto :: String -> C.Unit
578rpc_init_fn_proto n =
579    C.GVarDecl C.Extern C.NonConst
580         (C.Function C.NoScope (C.Void) (rpc_init_fn_params n)) name Nothing
581    where
582        name = rpc_init_fn_name n
583        rpc_init_fn_params n = [C.Param (C.Ptr $ C.Struct (intf_bind_type n)) "binding"]
584
585--
586-- Generate send function inline wrappers for each message signature
587--
588
589tx_wrapper :: String -> MessageDef -> C.Unit
590tx_wrapper ifn (Message _ mn args _)
591    = C.StaticInline (C.TypeName "errval_t") (tx_wrapper_name ifn mn)
592        ([ binding_param ifn, continuation ] ++ concat payload_params)
593        [ C.Return $ C.CallInd (bindvar `C.DerefField` "tx_vtbl" `C.FieldOf` mn)
594                ([bindvar, C.Variable intf_cont_var] ++ payload_args) ]
595  where
596    continuation = C.Param (C.Struct "event_closure") intf_cont_var
597    payload_params = [ msg_argdecl TX ifn a | a <- args ]
598    payload_args = map C.Variable $ concat $ map mkargs args
599    mkargs (Arg _ (Name an)) = [an]
600    mkargs (Arg _ (StringArray an _)) = [an]
601    mkargs (Arg _ (DynamicArray an al _)) = [an, al]
602
603--
604-- Include the right files for different backends
605--
606
607flounder_backends = [ "lmp", "ump", "ump_ipi", "multihop", "local" ]
608
609backend_includes :: String -> [ C.Unit ]
610backend_includes n =
611    [ backend_include n b | b <- flounder_backends ]
612
613backend_include n b =
614    C.IfDef ("CONFIG_FLOUNDER_BACKEND_" ++ (map toUpper b))
615    [ C.Include C.Standard ("if/" ++ n ++ "_" ++ b ++ "_defs.h") ]
616     []
617
618-----------------------------------------------------------------
619-- Code to generate concrete type definitions
620-----------------------------------------------------------------
621
622define_types :: String -> [TypeDef] -> [C.Unit]
623define_types interfaceName types =
624    [ define_type interfaceName t | t <- types ]
625
626define_type :: String -> TypeDef -> C.Unit
627define_type ifname (TAliasT newType originType) =
628    C.TypeDef (type_c_type ifname $ Builtin originType) (type_c_name1 ifname newType)
629
630{-
631A typedef'd alias:
632\begin{verbatim}
633typedef uint32 alias_type;
634\end{verbatim}
635
636Should compile to:
637\begin{verbatim}
638typedef uint32_t ifname_alias_type_t;
639\end{verbatim}
640-}
641
642define_type ifname (TAlias newType originType) =
643    C.TypeDef (type_c_type ifname originType) (type_c_name1 ifname newType)
644
645{-
646For @TArray@, we have to map the type @name@ to an array of @length@
647elements of type @typeElts@. In C, this surprisingly corresponds to
648the, correct, following code:
649
650\begin{verbatim}
651typedef typeElts name[length]
652\end{verbatim}
653
654So, we will compile:
655\begin{verbatim}
656typedef uint32 array_type[30];
657\end{verbatim}
658
659To the following type definition:
660\begin{verbatim}
661typedef uint32_t ifname_array_type_t[30]
662\end{verbatim}
663-}
664
665define_type ifname (TArray typeElts name length) =
666    C.TypeDef
667         (C.Array length $ type_c_type ifname typeElts)
668         (type_c_name1 ifname name)
669
670
671{-
672The following structure:
673\begin{verbatim}
674typedef struct {
675    uint32 int_field;
676    alias_type alias_field;
677} struct_type;
678\end{verbatim}
679
680Should be compiled down to:
681\begin{verbatim}
682typedef struct _ifname_struct_type_t {
683    uint32_t    int_field;
684    ifname_alias_type_t    alias_field;
685} ifname_struct_type_t;
686\end{verbatim}
687-}
688
689define_type ifname (TStruct name fields) =
690    let struct_name = type_c_struct ifname name
691        type_name = type_c_name1 ifname name
692    in
693      C.UnitList [
694            (C.StructDecl struct_name
695                  [ C.Param (type_c_type ifname ft) fn
696                        | TStructField ft fn <- fields ]),
697            C.TypeDef (C.Struct struct_name) type_name ]
698
699{-
700This enumeration:
701\begin{verbatim}
702typedef enum {
703    foo, bar, baz
704} some_enum;
705\end{verbatim}
706
707Generates the following code:
708\begin{verbatim}
709enum ifname_some_enum_t {
710    ifname_some_enum_t_foo = 1,
711    ifname_some_enum_t_bar = 2,
712    ifname_some_enum_t_baz = 3,
713}
714\end{verbatim}
715-}
716
717define_type ifname (TEnum name elements) =
718    C.EnumDecl (type_c_name1 ifname name)
719         [ C.EnumItem (type_c_enum ifname e) Nothing | e <- elements ]
720