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