1{- 2 MsgBuf.hs: Flounder stub generator for marshalling into / out of in-memory 3 message buffers 4 5 Part of Flounder: a message passing IDL for Barrelfish 6 7 Copyright (c) 2007-2010, ETH Zurich. 8 All rights reserved. 9 10 This file is distributed under the terms in the attached LICENSE file. 11 If you do not find this file, copies can be found by writing to: 12 ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group. 13-} 14 15module MsgBuf where 16 17import qualified CAbsSyntax as C 18import qualified Backend 19import BackendCommon hiding (errvar) 20import Syntax 21 22------------------------------------------------------------------------ 23-- Language mapping: C identifier names 24------------------------------------------------------------------------ 25 26-- Name of the marshall functions 27tx_fn_name ifn mn = idscope ifn mn "msgbuf_marshall" 28rx_fn_name ifn = ifscope ifn "msgbuf_dispatch" 29 30msgbuf_name = "_msg" 31msgbuf_var = C.Variable msgbuf_name 32 33errvar_name = "_err" 34errvar = C.Variable errvar_name 35 36------------------------------------------------------------------------ 37-- Language mapping: Create the header file for this interconnect driver 38------------------------------------------------------------------------ 39 40header :: String -> String -> Interface -> String 41header infile outfile intf = 42 unlines $ C.pp_unit $ header_file intf (header_body infile intf) 43 where 44 header_file :: Interface -> [C.Unit] -> C.Unit 45 header_file interface@(Interface name _ _) body = 46 let sym = "__" ++ name ++ "_MSGBUF_STUB_H" 47 in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) [] 48 49header_body :: String -> Interface -> [C.Unit] 50header_body infile interface@(Interface ifn descr decls) = [ 51 intf_preamble infile ifn descr, 52 C.Blank, 53 C.MultiComment [ "Generic message buffer marshalling header" ], 54 C.Blank, 55 C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"), 56 C.Blank, 57 C.UnitList [ tx_fn_proto ifn m | m <- msgs ], 58 C.Blank, 59 rx_fn_proto ifn] 60 where 61 (types, msgs) = Backend.partitionTypesMessages decls 62 63tx_fn_proto :: String -> MessageDef -> C.Unit 64tx_fn_proto ifn msg = 65 C.GVarDecl C.NoScope C.NonConst 66 (C.Function C.NoScope (C.TypeName "errval_t") (tx_fn_params ifn msg)) 67 (tx_fn_name ifn (msg_name msg)) Nothing 68 69tx_fn_params :: String -> MessageDef -> [C.Param] 70tx_fn_params ifn (Message _ _ args _) 71 = [ C.Param (C.Ptr $ C.Struct "msgbuf") msgbuf_name ] 72 ++ concat [ msg_argdecl TX ifn a | a <- args ] 73 74rx_fn_proto :: String -> C.Unit 75rx_fn_proto ifn = 76 C.GVarDecl C.NoScope C.NonConst 77 (C.Function C.NoScope (C.TypeName "errval_t") (rx_fn_params ifn)) 78 (rx_fn_name ifn) Nothing 79 80rx_fn_params :: String -> [C.Param] 81rx_fn_params ifn = 82 [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 83 C.Param (C.Ptr $ C.Struct "msgbuf") msgbuf_name] 84 85------------------------------------------------------------------------ 86-- Language mapping: Create the stub (implementation) for this interconnect driver 87------------------------------------------------------------------------ 88 89stub :: String -> String -> Interface -> String 90stub infile outfile intf = unlines $ C.pp_unit $ stub_body infile intf 91 92stub_body :: String -> Interface -> C.Unit 93stub_body infile intf@(Interface ifn descr decls) = C.UnitList [ 94 intf_preamble infile ifn descr, 95 C.Blank, 96 C.MultiComment [ "Generic message buffer marshalling stubs" ], 97 C.Blank, 98 99 C.Include C.Standard "barrelfish/barrelfish.h", 100 C.Include C.Standard "barrelfish/msgbuf.h", 101 C.Include C.Standard ("if/" ++ ifn ++ "_msgbuf_defs.h"), 102 C.Blank, 103 104 C.MultiComment [ "Marshalling functions" ], 105 C.UnitList [ tx_fn ifn m | m <- msgs ], 106 C.Blank, 107 108 C.MultiComment [ "Demarshall/dispatch function" ], 109 rx_fn ifn msgs 110 ] 111 where 112 (types, msgs) = Backend.partitionTypesMessages decls 113 114tx_fn :: String -> MessageDef -> C.Unit 115tx_fn ifn msg@(Message _ mn args _) = 116 C.FunctionDef C.NoScope (C.TypeName "errval_t") (tx_fn_name ifn mn) (tx_fn_params ifn msg) 117 [ 118 localvar (C.TypeName "errval_t") errvar_name Nothing, 119 C.SBlank, 120 C.StmtList $ concat [ handle_marshall $ marshall_arg a | a <- msgnum_arg:args ], 121 C.Return $ C.Variable "SYS_ERR_OK" 122 ] where 123 msgnum_arg = Arg (Builtin msg_code_type) (Name $ msg_enum_elem_name ifn mn) 124 125 handle_marshall :: C.Expr -> [C.Stmt] 126 handle_marshall marshall_expr = 127 [C.Ex $ C.Assignment errvar marshall_expr, 128 C.If (C.Call "err_is_fail" [errvar]) 129 [C.Return errvar] []] 130 131 marshall_arg :: MessageArgument -> C.Expr 132 marshall_arg (Arg (TypeAlias _ b) v) = marshall_arg (Arg (Builtin b) v) 133 marshall_arg (Arg (Builtin b) (Name n)) 134 = C.Call ("msgbuf_marshall_" ++ (show b)) [msgbuf_var, C.Variable n] 135 marshall_arg (Arg (Builtin b) (DynamicArray n l _)) 136 | b `elem` [Int8, UInt8, Char] 137 = C.Call "msgbuf_marshall_buffer" [msgbuf_var, C.Variable n, C.Variable l] 138 | otherwise = error "dynamic arrays are NYI for MsgBuf backend" 139 marshall_arg a = error $ "complex types are NYI for MsgBuf backend: " ++ show a 140 141rx_fn :: String -> [MessageDef] -> C.Unit 142rx_fn ifn msgs = 143 C.FunctionDef C.NoScope (C.TypeName "errval_t") (rx_fn_name ifn) (rx_fn_params ifn) 144 [ 145 localvar (C.TypeName "errval_t") errvar_name Nothing, 146 localvar (C.TypeName msg_code_ctype) "msgnum" Nothing, 147 C.SBlank, 148 C.SComment "unmarshall message code", 149 C.Ex $ C.Assignment errvar (C.Call msg_code_unmarshall_func 150 [msgbuf_var, 151 C.AddressOf $ C.Variable "msgnum"]), 152 C.If (C.Call "err_is_fail" [errvar]) [C.Return errvar] [], 153 C.SBlank, 154 C.Switch (C.Variable "msgnum") cases 155 [C.Return $ C.Variable "FLOUNDER_ERR_RX_INVALID_MSGNUM"], 156 C.SBlank, 157 C.Return $ C.Variable "SYS_ERR_OK" 158 ] where 159 cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) [handle_msg mn args] 160 | Message _ mn args _ <- msgs] 161 162 handle_msg :: String -> [MessageArgument] -> C.Stmt 163 handle_msg mn args = C.Block [ 164 localvar (C.Struct $ msg_argstruct_name RX ifn mn) "args" Nothing, 165 C.SBlank, 166 C.StmtList $ concat $ map (handle_unmarshall.unmarshall_arg) args, 167 C.Ex $ C.Call "assert" [C.Binary C.NotEquals rx_handler (C.Variable "NULL")], 168 C.Ex $ C.CallInd rx_handler rx_handler_args, 169 C.Break 170 ] where 171 rx_handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn 172 rx_handler_args = [bindvar] ++ (map arg_field $ concat $ map mkargs args) 173 174 mkargs (Arg _ (Name n)) = [n] 175 mkargs (Arg _ (DynamicArray n l _)) = [n, l] 176 177 handle_unmarshall :: C.Expr -> [C.Stmt] 178 handle_unmarshall unmarshall_expr = 179 [C.Ex $ C.Assignment errvar unmarshall_expr, 180 C.If (C.Call "err_is_fail" [errvar]) 181 [C.Return errvar] []] 182 183 unmarshall_arg :: MessageArgument -> C.Expr 184 unmarshall_arg (Arg (TypeAlias _ b) v) = unmarshall_arg (Arg (Builtin b) v) 185 unmarshall_arg (Arg (Builtin b) (Name n)) 186 = C.Call ("msgbuf_unmarshall_" ++ (show b)) 187 [msgbuf_var, C.AddressOf $ arg_field n] 188 unmarshall_arg (Arg (Builtin b) (DynamicArray n l _)) 189 | b `elem` [Int8, UInt8, Char] 190 = C.Call "msgbuf_unmarshall_buffer" 191 [msgbuf_var, C.AddressOf $ arg_field l, 192 C.Cast (C.Ptr $ C.Ptr C.Void) $ C.AddressOf $ arg_field n] 193 | otherwise = error "dynamic arrays are NYI for MsgBuf backend" 194 unmarshall_arg a = error $ "complex types are NYI for MsgBuf backend: " ++ show a 195 196 arg_field n = (C.Variable "args") `C.FieldOf` n 197 198 199msg_code_type = UInt16 200msg_code_ctype = "uint16_t" 201msg_code_unmarshall_func = "msgbuf_unmarshall_uint16" 202