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