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