1{- 2 Loopback.hs: Flounder stub generator for dummy loopback 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 Loopback 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 = "loopback" 26 27-- Name of the init function 28loopback_init_fn_name n = ifscope n "loopback_init" 29 30-- Name of the transmit vtable 31loopback_vtbl_name ifn = ifscope ifn "loopback_tx_vtbl" 32 33-- Name of the transmit function 34tx_fn_name ifn mn = idscope ifn mn "loopback_send" 35 36change_waitset_fn_name ifn = ifscope ifn "loopback_change_waitset" 37 38------------------------------------------------------------------------ 39-- Language mapping: Create the header file for this interconnect driver 40------------------------------------------------------------------------ 41 42header :: String -> String -> Interface -> String 43header infile outfile intf@(Interface name descr decls) = 44 unlines $ C.pp_unit $ header_file intf header_body 45 where 46 header_file :: Interface -> [C.Unit] -> C.Unit 47 header_file interface@(Interface name _ _) body = 48 let sym = "__" ++ name ++ "_LOOPBACK_H" 49 in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) [] 50 51 header_body = [ 52 intf_preamble infile name descr, 53 C.Blank, 54 C.MultiComment [ "Loopback interconnect driver" ], 55 C.Blank, 56 loopback_init_function_proto name] 57 58loopback_init_function_proto :: String -> C.Unit 59loopback_init_function_proto n = 60 C.GVarDecl C.Extern C.NonConst 61 (C.Function C.NoScope C.Void params) name Nothing 62 where 63 name = loopback_init_fn_name n 64 params = [C.Param (C.Ptr $ C.Struct (intf_bind_type n)) intf_bind_var] 65 66------------------------------------------------------------------------ 67-- Language mapping: Create the stub (implementation) for this interconnect driver 68------------------------------------------------------------------------ 69 70stub :: String -> String -> Interface -> String 71stub infile outfile intf = 72 unlines $ C.pp_unit $ loopback_stub_body infile intf 73 74loopback_stub_body :: String -> Interface -> C.Unit 75loopback_stub_body infile intf@(Interface ifn descr decls) = C.UnitList [ 76 intf_preamble infile ifn descr, 77 C.Blank, 78 C.MultiComment [ "Generated Loopback stub" ], 79 C.Blank, 80 81 C.Define "_USE_XOPEN" [] "/* for strdup() */", 82 C.Include C.Standard "string.h", 83 C.Include C.Standard "barrelfish/barrelfish.h", 84 C.Include C.Standard "flounder/flounder_support.h", 85 C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"), 86 C.Include C.Standard ("if/" ++ ifn ++ "_loopback_defs.h"), 87 C.Blank, 88 89 C.MultiComment [ "Message sender functions" ], 90 C.UnitList [ tx_fn ifn m | m <- messages ], 91 C.Blank, 92 93 C.MultiComment [ "Send vtable" ], 94 tx_vtbl ifn messages, 95 96 C.MultiComment [ "Control functions" ], 97 can_send_fn_def ifn, 98 register_send_fn_def ifn, 99 default_error_handler_fn_def drvname ifn, 100 change_waitset_fn_def ifn, 101 generic_control_fn_def drvname ifn, 102 103 C.MultiComment [ "Function to initialise the binding state" ], 104 loopback_init_fn ifn] 105 where 106 (types, messagedecls) = Backend.partitionTypesMessages decls 107 messages = rpcs_to_msgs messagedecls 108 109loopback_init_fn :: String -> C.Unit 110loopback_init_fn ifn 111 = C.FunctionDef C.NoScope C.Void (loopback_init_fn_name ifn) params [ 112 C.StmtList common_init, 113 C.Ex $ C.Assignment (common_field "change_waitset") 114 (C.Variable $ change_waitset_fn_name ifn), 115 C.Ex $ C.Assignment (common_field "control") 116 (C.Variable $ generic_control_fn_name drvname ifn) 117 ] 118 where 119 params = [C.Param (C.Ptr $ C.Struct (intf_bind_type ifn)) intf_bind_var] 120 common_field f = (C.Variable intf_bind_var) `C.DerefField` f 121 common_init = binding_struct_init "loopback" ifn 122 (C.DerefPtr $ C.Variable intf_bind_var) 123 (C.Variable "NULL") 124 (C.Variable $ loopback_vtbl_name ifn) 125 126can_send_fn_def :: String -> C.Unit 127can_send_fn_def ifn = 128 C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drvname ifn) params [ 129 C.Return $ C.Variable "true"] 130 where 131 params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b" ] 132 133register_send_fn_def :: String -> C.Unit 134register_send_fn_def ifn = 135 C.FunctionDef C.Static (C.TypeName "errval_t") (register_send_fn_name drvname ifn) params [ 136 C.Return $ C.Variable "ERR_NOTIMP" 137 ] 138 where 139 params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b", 140 C.Param (C.Ptr $ C.Struct "waitset") "ws", 141 C.Param (C.Struct "event_closure") intf_cont_var ] 142 143change_waitset_fn_def :: String -> C.Unit 144change_waitset_fn_def ifn = 145 C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name ifn) params [ 146 C.Return $ C.Variable "ERR_NOTIMP" 147 ] 148 where 149 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 150 C.Param (C.Ptr $ C.Struct "waitset") "ws"] 151 152tx_fn :: String -> MessageDef -> C.Unit 153tx_fn ifn msg@(Message _ mn args _) = 154 C.FunctionDef C.Static (C.TypeName "errval_t") (tx_fn_name ifn mn) params body 155 where 156 params = [binding_param ifn, cont_param] ++ ( 157 concat [ msg_argdecl TX ifn a | a <- args ]) 158 cont_param = C.Param (C.Struct "event_closure") intf_cont_var 159 body = [ 160 C.StmtList $ if length arrayargs > 0 then 161 [C.SComment "copy array arguments", 162 C.StmtList $ concat $ map copyarray arrayargs 163 ] else [], 164 C.SComment "call rx handler", 165 C.Ex $ C.Call "assert" [C.Binary C.NotEquals handler (C.Variable "NULL")], 166 C.Ex $ C.CallInd handler ((C.Variable intf_bind_var):(concat $ map mkvars args)), 167 C.SBlank, 168 C.SComment "run continuation, if any", 169 C.If (C.Binary C.NotEquals 170 (C.Variable intf_cont_var `C.FieldOf` "handler") 171 (C.Variable "NULL")) 172 [C.Ex $ C.CallInd (C.Variable intf_cont_var `C.FieldOf` "handler") 173 [C.Variable intf_cont_var `C.FieldOf` "arg"]] [], 174 C.SBlank, 175 C.Return $ C.Variable "SYS_ERR_OK" 176 ] 177 178 arrayargs = [a | a@(Arg _ (DynamicArray _ _ _)) <- args] 179 180 copyarray (Arg tr (DynamicArray n l _)) = [ 181 localvar array_type (array_copy_name n) 182 $ Just $ C.Call "malloc" [size], 183 C.If (C.Binary C.Equals copyvar (C.Variable "NULL")) 184 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 185 C.Ex $ C.Call "memcpy" [copyvar, srcvar, size] 186 ] where 187 srcvar = C.Variable n 188 copyvar = C.Variable $ array_copy_name n 189 array_type = C.Ptr $ type_c_type ifn tr 190 size = C.Binary C.Times (C.SizeOfT $ type_c_type ifn tr) (C.Variable l) 191 192 -- string and array arguments need special treatment 193 mkvars (Arg (Builtin String) (Name n)) = [C.Call "strdup" [C.Variable n]] 194 mkvars (Arg _ (StringArray n _)) = [C.Variable n] 195 mkvars (Arg _ (DynamicArray n l _)) = [C.Variable $ array_copy_name n, C.Variable l] 196 mkvars (Arg _ (Name n)) = [C.Variable n] 197 198 array_copy_name n = "_copy_of_" ++ n 199 200 binding = C.Variable intf_bind_var 201 handler = C.FieldOf (C.DerefField binding "rx_vtbl") mn 202 203tx_vtbl :: String -> [MessageDef] -> C.Unit 204tx_vtbl ifn ml = 205 C.StructDef C.Static (intf_vtbl_type ifn TX) (loopback_vtbl_name ifn) fields 206 where 207 fields = [let mn = msg_name m in (mn, tx_fn_name ifn mn) | m <- ml] 208