1{-
2   Local.hs: Flounder stub generator for dummy local 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 Local where
15
16import qualified CAbsSyntax as C
17import qualified Backend
18import Syntax
19import BackendCommon hiding (can_send_fn_def, register_send_fn_def)
20
21------------------------------------------------------------------------
22-- Language mapping: C identifier names
23------------------------------------------------------------------------
24
25drvname = "local"
26
27-- Name of the init function
28local_init_fn_name n = ifscope n "local_init"
29
30-- Name of the transmit vtable
31local_vtbl_name ifn = ifscope ifn "local_tx_vtbl"
32
33-- Name of the transmit function
34tx_fn_name ifn mn = idscope ifn mn "local_send"
35
36change_waitset_fn_name ifn = ifscope ifn "local_change_waitset"
37get_receiving_chanstate_fn_name ifn = ifscope ifn "local_get_receiving_chanstate"
38    
39------------------------------------------------------------------------
40-- Language mapping: Create the header file for this interconnect driver
41------------------------------------------------------------------------
42
43header :: String -> String -> Interface -> String
44header infile outfile intf@(Interface name descr decls) =
45    unlines $ C.pp_unit $ header_file intf header_body
46    where
47        header_file :: Interface -> [C.Unit] -> C.Unit
48        header_file interface@(Interface name _ _) body =
49            let sym = "__" ++ name ++ "_LOCAL_H"
50            in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
51
52        header_body = [
53            intf_preamble infile name descr,
54            C.Blank,
55            C.MultiComment [ "Local interconnect driver" ],
56            C.Blank,
57            local_init_function_proto name,
58            local_connect_handler_proto name
59            ]
60
61local_init_function_proto :: String -> C.Unit
62local_init_function_proto n =
63    C.GVarDecl C.Extern C.NonConst
64         (C.Function C.NoScope C.Void params) name Nothing
65    where
66      name = local_init_fn_name n
67      params = [C.Param (C.Ptr $ C.Struct (intf_bind_type n)) "local_binding",
68                C.Param (C.Ptr $ C.Struct "waitset") "waitset",
69                C.Param (C.Ptr $ C.Struct (intf_bind_type n)) "my_binding"]
70
71local_connect_handler_proto :: String -> C.Unit
72local_connect_handler_proto ifn = C.GVarDecl C.Extern C.NonConst
73    (C.Function C.NoScope (C.TypeName "errval_t") local_connect_handler_params)
74    (drv_connect_handler_name drvname ifn) Nothing
75
76local_connect_handler_params :: [C.Param]
77local_connect_handler_params
78    = [C.Param (C.Ptr $ C.Void) "st",
79       C.Param (C.Ptr $ C.Void) "local_binding",
80       C.Param (C.Ptr $ C.Ptr $ C.Void) "my_binding"]
81
82------------------------------------------------------------------------
83-- Language mapping: Create the stub (implementation) for this interconnect driver
84------------------------------------------------------------------------
85
86stub :: String -> String -> Interface -> String
87stub infile outfile intf =
88    unlines $ C.pp_unit $ local_stub_body infile intf
89
90local_stub_body :: String -> Interface -> C.Unit
91local_stub_body infile intf@(Interface ifn descr decls) = C.UnitList [
92    intf_preamble infile ifn descr,
93    C.Blank,
94    C.MultiComment [ "Generated Local stub" ],
95    C.Blank,
96
97    C.Define "_USE_XOPEN" [] "/* for strdup() */",
98    C.Include C.Standard "string.h",
99    C.Include C.Standard "barrelfish/barrelfish.h",
100    C.Include C.Standard "flounder/flounder_support.h",
101    C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"),
102    C.Include C.Standard ("if/" ++ ifn ++ "_local_defs.h"),
103    C.Blank,
104
105    C.MultiComment [ "Message sender functions" ],
106    C.UnitList [ tx_fn ifn m | m <- messages ],
107    C.Blank,
108
109    C.MultiComment [ "Send vtable" ],
110    tx_vtbl ifn messages,
111
112    C.MultiComment [ "Control functions" ],
113    can_send_fn_def ifn,
114    register_send_fn_def ifn,
115    default_error_handler_fn_def drvname ifn,
116    change_waitset_fn_def ifn,
117    generic_control_fn_def drvname ifn,
118    get_receiving_chanstate_fn_def ifn,
119
120    C.MultiComment [ "Function to initialise the binding state" ],
121    local_init_fn ifn,
122
123    C.MultiComment [ "Connect callback for export" ],
124    local_connect_handler_fn ifn
125    ]
126    where
127        (types, messagedecls) = Backend.partitionTypesMessages decls
128        messages = rpcs_to_msgs messagedecls
129
130local_init_fn :: String -> C.Unit
131local_init_fn ifn
132    = C.FunctionDef C.NoScope C.Void (local_init_fn_name ifn) params [
133        C.StmtList common_init,
134        C.Ex $ C.Assignment (common_field "change_waitset")
135                                (C.Variable $ change_waitset_fn_name ifn),
136        C.Ex $ C.Assignment (common_field "control")
137                                (C.Variable $ generic_control_fn_name drvname ifn),
138        C.Ex $ C.Assignment (common_field "local_binding")
139                                (C.Variable "local_binding"),
140        C.Ex $ C.Assignment (common_field "get_receiving_chanstate")
141                    (C.Variable $ get_receiving_chanstate_fn_name ifn)
142    ]
143    where
144      params = [C.Param (C.Ptr $ C.Struct (intf_bind_type ifn)) intf_bind_var,
145                C.Param (C.Ptr $ C.Struct "waitset") "waitset",
146                C.Param (C.Ptr $ C.Struct (intf_bind_type ifn)) "local_binding"]
147      common_field f = (C.Variable intf_bind_var) `C.DerefField` f
148      common_init = binding_struct_init "local" ifn
149        (C.DerefPtr $ C.Variable intf_bind_var)
150        (C.Variable "waitset")
151        (C.Variable $ local_vtbl_name ifn)
152
153can_send_fn_def :: String -> C.Unit
154can_send_fn_def ifn =
155    C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drvname ifn) params [
156        C.Return $ C.Variable "true"]
157    where
158        params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b" ]
159
160register_send_fn_def :: String -> C.Unit
161register_send_fn_def ifn =
162    C.FunctionDef C.Static (C.TypeName "errval_t") (register_send_fn_name drvname ifn) params [
163        C.Return $ C.Variable "ERR_NOTIMP"
164    ]
165    where
166        params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b",
167                   C.Param (C.Ptr $ C.Struct "waitset") "ws",
168                   C.Param (C.Struct "event_closure") intf_cont_var ]
169
170change_waitset_fn_def :: String -> C.Unit
171change_waitset_fn_def ifn =
172    C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name ifn) params [
173        C.Return $ C.Variable "ERR_NOTIMP"
174    ]
175    where
176        params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var,
177                  C.Param (C.Ptr $ C.Struct "waitset") "ws"]
178
179tx_fn :: String -> MessageDef -> C.Unit
180tx_fn ifn msg@(Message _ mn args _) =
181    C.FunctionDef C.Static (C.TypeName "errval_t") (tx_fn_name ifn mn) params body
182    where
183        params = [binding_param ifn, cont_param] ++ (
184                    concat [ msg_argdecl TX ifn a | a <- args ])
185        cont_param = C.Param (C.Struct "event_closure") intf_cont_var
186        body = [
187            C.SComment "call rx handler",
188            C.Ex $ C.Call "assert" [C.Binary C.NotEquals handler (C.Variable "NULL")],
189            C.Ex $ C.CallInd handler ((local_binding):(concat $ map mkvars args)),
190            C.SBlank,
191            C.SComment "run continuation, if any",
192            C.If (C.Binary C.And (C.Binary C.NotEquals
193                                (C.Variable intf_cont_var `C.FieldOf` "handler")
194                                (C.Variable "NULL"))
195                (C.Binary C.NotEquals
196                        (C.Variable intf_cont_var `C.FieldOf` "handler")
197                        (C.Variable "blocking_cont")))
198                [C.Ex $ C.CallInd (C.Variable intf_cont_var `C.FieldOf` "handler")
199                                [C.Variable intf_cont_var `C.FieldOf` "arg"]] [],
200            C.SBlank,
201            C.Return $ C.Variable "SYS_ERR_OK"
202            ]
203        -- string and array arguments need special treatment
204        mkvars (Arg _ (StringArray n l)) = [C.Variable n]
205        mkvars (Arg _ (DynamicArray n l _)) = [C.Variable n, C.Variable l]
206        mkvars (Arg _ (Name n)) = [C.Variable n]
207
208        binding = C.Variable intf_bind_var
209        local_binding = C.DerefField binding "local_binding"
210        handler = C.FieldOf (C.DerefField local_binding "rx_vtbl") mn
211
212tx_vtbl :: String -> [MessageDef] -> C.Unit
213tx_vtbl ifn ml =
214    C.StructDef C.Static (intf_vtbl_type ifn TX) (local_vtbl_name ifn) fields
215    where
216        fields = [let mn = msg_name m in (mn, tx_fn_name ifn mn) | m <- ml]
217
218local_connect_handler_fn :: String -> C.Unit
219local_connect_handler_fn ifn = C.FunctionDef C.NoScope (C.TypeName "errval_t")
220    (drv_connect_handler_name "local" ifn) local_connect_handler_params [
221
222    localvar (C.Ptr $ C.Struct $ export_type ifn) "e" $ Just $ C.Variable "st",
223    localvar (C.TypeName "errval_t") "err" Nothing,
224    C.SBlank,
225    C.SComment "allocate storage for binding",
226    localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var
227        $ Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ intf_bind_type ifn],
228    C.If (C.Binary C.Equals (C.Variable intf_bind_var) (C.Variable "NULL"))
229        [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [],
230    C.SBlank,
231
232    C.Ex $ C.Call (local_init_fn_name ifn) [binding,
233        C.DerefField (C.Cast (C.Ptr $ C.Struct $ intf_bind_type ifn) (C.Variable "local_binding")) "waitset",
234        C.Variable "local_binding"],
235    C.SComment "run user's connect handler",
236    C.Ex $ C.Call "assert" [(C.DerefField exportvar "connect_cb")],
237    C.Ex $ C.Assignment errvar $ C.CallInd (C.DerefField exportvar "connect_cb")
238                       [C.DerefField exportvar "st", bindvar],
239    C.If (C.Call "err_is_fail" [errvar])
240        [C.SComment "connection refused",
241         C.Return $ errvar] [],
242    C.SBlank,
243    C.Ex $ C.Assignment (C.DerefPtr $ C.Variable "my_binding") binding,
244    C.Return $ C.Variable "SYS_ERR_OK"]
245    where
246        exportvar = C.Variable "e"
247        binding = C.Variable intf_bind_var
248
249get_receiving_chanstate_fn_def :: String -> C.Unit
250get_receiving_chanstate_fn_def ifn =
251    C.FunctionDef C.Static (C.Ptr $ C.Struct "waitset_chanstate") (get_receiving_chanstate_fn_name ifn) params [
252        C.Return $ C.Variable "NULL"]
253    where
254        params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var]
255