887bf1f2eb505edff48e80c4b9e1c181bdf8d1e8
[barrelfish] / tools / sockeye / SockeyeHeaderBackend.hs
1 {- 
2    GHBackend: Flounder stub generator for generic header files
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
14 module SockeyeHeaderBackend where
15
16 import Data.List
17 import Data.Char
18
19 import qualified CAbsSyntax as C
20 import SockeyeSyntax
21
22
23 import qualified Backend
24 import BackendCommon
25
26
27 add_fn_name n = ifscope n "add"
28
29
30 ------------------------------------------------------------------------
31 -- Language mapping: Create the generic header file for the interface
32 ------------------------------------------------------------------------
33
34 compile :: String -> String -> Schema -> String
35 compile infile outfile schema = 
36     unlines $ C.pp_unit $ sockeye_header_file infile schema
37
38
39 header_file :: String -> Schema -> [C.Unit] -> C.Unit
40 header_file infile schema@(Schema name _ _) body = 
41     let sym = "__SCHEMA_" ++ map toUpper name ++ "_H"
42     in
43       C.IfNDef sym ([ C.Define sym [] "1"] ++ body) []
44
45
46 sockeye_header_file :: String -> Schema -> C.Unit
47 sockeye_header_file infile intf = 
48     header_file infile intf (schema_header_body infile intf)
49
50
51 schema_header_body :: String -> Schema -> [C.Unit]
52 schema_header_body infile schema@(Schema name descr decls) = 
53     let
54         (types, facts, queries) = Backend.partitionTypesFactsQueries decls
55         --messages = rpcs_to_msgs messagedecls
56     in
57       [ schema_preamble infile name descr,
58         C.Blank,
59
60         C.Include C.Standard "skb/skb.h",
61         C.Blank,
62
63         C.MultiComment [ "Concrete type definitions" ],
64         C.UnitList $ define_types name types,
65         C.Blank,
66         C.Blank,
67
68         C.MultiComment [ "Fact attribute fields" ],
69         C.Blank,
70         C.UnitList [ fact_attributes name f | f <- facts ],
71         C.Blank,
72
73         C.MultiComment [ "Fact type signatures" ],
74         C.Blank,
75         C.UnitList [ fact_signature name f | f <- facts ],
76         C.Blank,
77
78         C.MultiComment [ "Query type signatures" ],
79         C.Blank,
80         C.UnitList [ query_signature name q | q <- queries ],
81         C.Blank
82       ]
83
84
85
86 --
87 -- Generate type definitions for each fact signature
88 --
89    
90
91
92
93 fact_signature :: String -> FactDef -> C.Unit
94 fact_signature sname f = C.UnitList [
95     C.MultiDoxy (["@brief  " ++ desc,
96                   ""] ++ param_desc),
97     C.FunctionDecl C.NoScope (C.TypeName "errval_t") name params,
98     C.Blank
99   ]
100   where
101     name = fact_sig_type sname "add" f
102     desc = fact_desc f
103     params = [C.Param (C.Ptr $ C.Struct $ (fact_attrib_type sname f)) "arg"]
104     param_desc = [ fact_param_desc a | a <- fact_args f ]
105     payload = case f of
106         Fact _ _ args -> [ fact_argdecl sname a | a <- args ]
107
108
109
110 query_signature :: String -> QueryDef -> C.Unit
111 query_signature sname q =
112   C.FunctionDecl C.NoScope (C.TypeName "errval_t") name params
113   where
114     name = query_sig_type sname q
115     params = concat payload
116     payload = case q of
117         Query _ _ args -> [ query_argdecl sname a | a <- args ]
118
119
120 fact_attributes :: String -> FactDef -> C.Unit
121 fact_attributes sname f = C.UnitList [
122     C.MultiDoxy (["Fact: " ++ name,
123                   "@brief  " ++ desc]),
124     C.StructDecl name params,
125     C.Blank,
126     C.DoxyComment ("typedef for the " ++ name ++ " attribute type"),
127     C.TypeDef (C.Struct name) (name ++ "_t"),
128     C.Blank,
129     fact_fmt_str sname f,
130     C.Blank
131   ]
132   where 
133     name = fact_attrib_type sname f
134     desc = fact_desc f
135     params = concat payload
136     payload = case f of
137         Fact _ _ args -> [ fact_attrib_decl sname a | a <- args ]
138
139
140 attr_fmt_type_wr :: String -> FactAttribute -> String
141 attr_fmt_type_wr sn (FAttrib t (Name n) d) = case t of
142     Builtin builtin ->  "\"%\" " ++ builtin_fmt_wr builtin
143     TypeVar name -> "\"typevar\""
144     FactType name -> type_c_define sn name "FMT_WRITE"
145     TypeAlias alias (Builtin builtin) -> "\"%\" " ++ builtin_fmt_rd builtin
146
147 attr_fmt_type_rd :: String -> FactAttribute -> String
148 attr_fmt_type_rd sn (FAttrib t (Name n) d) = case t of
149     Builtin builtin ->  "\"%\" " ++ builtin_fmt_rd builtin
150     TypeVar name -> "\"typevar\""
151     FactType name -> type_c_define sn name "FMT_READ"
152     TypeAlias alias (Builtin builtin) -> "\"%\" " ++ builtin_fmt_rd builtin
153
154 attr_access_rd :: String -> String -> FactAttribute -> String
155 attr_access_rd arg sn (FAttrib t (Name n) d) = case t of
156     FactType name -> type_c_define sn name "FIELDS(&("++"(" ++ arg ++ ")->" ++ n ++"))"
157     _ -> "(" ++ arg ++ ")->" ++ n
158
159 fact_fmt_str :: String -> FactDef -> C.Unit
160 fact_fmt_str sname f=  C.UnitList [
161     C.DoxyComment ("define for printing the " ++ name ++ " fact"),
162     (C.Define (type_c_define sname (fact_name f) "FMT_WRITE") [] params_wr),
163     C.DoxyComment ("define for reading the " ++ name ++ " fact"),
164     (C.Define (type_c_define sname (fact_name f) "FMT_READ") [] params_rd),
165     C.DoxyComment ("define for accessing the  " ++ name ++ "fact attributes"),
166     (C.Define (type_c_define sname (fact_name f) "FIELDS") [ "_arg" ] field_access),
167     C.Blank
168   ]
169   where
170     name = plfact_attrib_type sname f
171     desc = fact_desc f
172     params_wr = "\"" ++ name ++ "(\"" ++ (intercalate "\", \"" write) ++ "\")\""
173     write = case f of
174         Fact _ _ args -> [ (attr_fmt_type_wr sname a) | a <- args ]
175     params_rd = "\"" ++ name ++ "(\"" ++ (intercalate "\", \"" read) ++ "\")\""
176     read = case f of
177         Fact _ _ args -> [ (attr_fmt_type_rd sname a) | a <- args ]
178     field_access = (intercalate ", " fields)
179     fields = case f of
180         Fact _ _ args -> [ attr_access_rd "_arg" sname a | a <- args ]  
181
182 {-
183
184 --
185 -- Generate a struct to hold the arguments of a message while it's being sent.
186 -- 
187 msg_argstruct :: String -> [TypeDef] -> MessageDef -> C.Unit
188 msg_argstruct ifname typedefs m@(RPC n args _) = 
189     C.StructDecl (msg_argstruct_name ifname n) 
190          (concat [ rpc_argdecl ifname a | a <- args ])
191 msg_argstruct ifname typedefs m@(Message _ n [] _) = C.NoOp
192 msg_argstruct ifname typedefs m@(Message _ n args _) =
193     let tn = msg_argstruct_name ifname n
194     in
195       C.StructDecl tn (concat [ msg_argstructdecl ifname typedefs a
196                                | a <- args ])
197
198 --
199 -- Generate a union of all the above
200 -- 
201 intf_union :: String -> [MessageDef] -> C.Unit
202 intf_union ifn msgs = 
203     C.UnionDecl (binding_arg_union_type ifn)
204          ([ C.Param (C.Struct $ msg_argstruct_name ifn n) n
205             | m@(Message _ n a _) <- msgs, 0 /= length a ]
206           ++
207           [ C.Param (C.Struct $ msg_argstruct_name ifn n) n
208             | m@(RPC n a _) <- msgs, 0 /= length a ]
209          )
210
211 --
212 -- Generate a struct defn for a vtable for the interface
213 --
214 intf_vtbl :: String -> Direction -> [MessageDef] -> C.Unit
215 intf_vtbl n d ml = 
216     C.StructDecl (intf_vtbl_type n d) [ intf_vtbl_param n m d | m <- ml ]
217
218 intf_vtbl_param :: String -> MessageDef -> Direction ->  C.Param
219 intf_vtbl_param ifn m d = C.Param (C.Ptr $ C.TypeName $ msg_sig_type ifn m d) (msg_name m)
220
221 --
222 -----------------------------------------------------------------
223 -- Code to generate concrete type definitions
224 -----------------------------------------------------------------
225
226 -}
227
228 define_types :: String -> [TypeDef] -> [C.Unit]
229 define_types schemaName types = 
230     [ define_type schemaName t | t <- types ]
231
232 define_type :: String -> TypeDef -> C.Unit
233 define_type sname (TAliasT newType originType) =
234     C.TypeDef (type_c_type sname $ Builtin originType) (type_c_name1 sname newType)
235
236 {-
237 This enumeration:
238 \begin{verbatim}
239 typedef enum {
240     foo, bar, baz
241 } some_enum;
242 \end{verbatim}
243
244 Generates the following code:
245 \begin{verbatim}
246 enum ifname_some_enum_t {
247     ifname_some_enum_t_foo = 1,
248     ifname_some_enum_t_bar = 2,
249     ifname_some_enum_t_baz = 3,
250 }
251 \end{verbatim}
252 -}
253
254
255 define_type sname (TEnum name elements) = 
256     C.EnumDecl (type_c_name1 sname name) 
257          [ C.EnumItem (type_c_enum sname e) Nothing | e <- elements ]
258
259
260    
261
262 {-
263 A typedef'd alias:
264 \begin{verbatim}
265 typedef uint32 alias_type;
266 \end{verbatim}
267
268 Should compile to:
269 \begin{verbatim}
270 typedef uint32_t ifname_alias_type_t;
271 \end{verbatim}
272 -}
273
274 define_type sname (TAlias newType originType) =
275     C.TypeDef (type_c_type sname originType) (type_c_name1 sname newType)
276
277