Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 319 lines (296 sloc) 11.383 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module Q = QmlAst
19 module List = BaseList
20 module Format = BaseFormat
21
22 type env = IdentSet.t
23
24 type runtime_type_key = string
25 type runtime_rpc_key = string
26 type runtime_ident = string
27 type runtime_code_elt = {
28 ident : runtime_ident option;
29 client_equivalent : runtime_ident option;
30 defines : [ `rpc of runtime_rpc_key | `type_ of runtime_type_key | `nothing ];
31 ident_deps : runtime_ident list;
32 rpc_deps: runtime_rpc_key list;
33 type_deps : runtime_type_key list;
34 root : bool;
35 }
36 type runtime_code = runtime_code_elt list
37
38 module S =
39 struct
40 type t = env
41 let pass = "pass_GenerateServerAst"
42 let pp _ _ = ()
43 end
44 module R =
45 struct
46 include ObjectFiles.Make(S)
47 let load () =
48 let env = IdentSet.empty in
49 (* can't be a safe union because of fakesources *)
50 fold IdentSet.union env
51 let save ~loaded_env ~env =
52 let small_env = IdentSet.diff env loaded_env in
53 save small_env
54 end
55
56 let pp_ident_field f = function
57 | None -> Format.fprintf f "None"
58 | Some i -> Format.fprintf f "Some %s" i
59 let pp_defines f = function
60 | `nothing -> Format.fprintf f "`nothing"
61 | `rpc s -> Format.fprintf f "`rpc %s" s
62 | `type_ s -> Format.fprintf f "`type_ %s" s
63 let pp_ident_deps =
64 Format.pp_list ",@ " Format.pp_print_string
65 let pp_rpc_deps = pp_ident_deps
66 let pp_type_deps = pp_ident_deps
67 let pp_root = Format.pp_print_bool
68 let pp_code_elt f {ident; client_equivalent; defines; ident_deps; rpc_deps; type_deps; root} =
69 Format.fprintf f
70 "@[@[<v2>{@\n@[<2>ident: %a@]@\n[<2>client_equivalent: %a@]@\n@[<2>defines: %a@]@\n@[<2>ident_deps: %a@]@\n@[<2>type_deps: %a@]@\n@[<2>rpc_deps: %a@]@\n@[<2>root: %a@]@]@\n}@]"
71 pp_ident_field ident
72 pp_ident_field client_equivalent
73 pp_defines defines
74 pp_ident_deps ident_deps
75 pp_type_deps type_deps
76 pp_rpc_deps rpc_deps
77 pp_root root
78 let pp_code =
79 Format.pp_list "@\n" pp_code_elt
80
81 let is_root e =
82 QmlAstWalk.Expr.traverse_exists
83 (fun tra -> function
84 | Q.Lambda _ -> false
85 | Q.Apply _ -> true
86 | e -> tra e) e
87
88 type acc = {
89 mutable acc_rpc_deps : runtime_rpc_key list;
90 mutable acc_type_deps : runtime_type_key list;
91 mutable acc_rpc_def : runtime_rpc_key list;
92 mutable acc_type_def : runtime_type_key list;
93 mutable acc_ident_deps : IdentSet.t;
94 mutable acc_rec_ident_deps : IdentSet.t;
95 mutable acc_fun_action_deps : runtime_ident list;
96 }
97
98 let useless = function
99 | {acc_rpc_deps = [];
100 acc_type_deps = [];
101 acc_rpc_def = [];
102 acc_type_def = [];
103 acc_ident_deps = x;
104 acc_rec_ident_deps = _;
105 acc_fun_action_deps = []} when IdentSet.is_empty x -> true
106 | _ -> false
107 let useful acc = not (useless acc)
108
109 let process_toplevel_binding env rec_idents e =
110 let acc = {
111 acc_rpc_deps = [];
112 acc_type_deps = [];
113 acc_rpc_def = [];
114 acc_type_def = [];
115 acc_ident_deps = IdentSet.empty;
116 acc_rec_ident_deps = IdentSet.empty;
117 acc_fun_action_deps = [];
118 } in
119 let e =
120 QmlAstWalk.Expr.map
121 (fun e ->
122 match e with
123 | Q.Ident (_, i) ->
124 if IdentSet.mem i env then
125 (* dependencies only on toplevel useful idents (env)
126 * or rec_idents, because for recursive bindings, this is tricky *)
127 acc.acc_ident_deps <- IdentSet.add i acc.acc_ident_deps
128 else if IdentSet.mem i rec_idents then
129 acc.acc_rec_ident_deps <- IdentSet.add i acc.acc_rec_ident_deps;
130 e
131 | Q.Directive (label, `tagged_string (s, kind), _, _) ->
132 (match kind with
133 | Q.Type_def -> acc.acc_type_def <- s :: acc.acc_type_def
134 | Q.Type_use -> acc.acc_type_deps <- s :: acc.acc_type_deps
135 | Q.Rpc_def -> acc.acc_rpc_def <- s :: acc.acc_rpc_def
136 | Q.Rpc_use -> acc.acc_rpc_deps <- s :: acc.acc_rpc_deps
137 | Q.Client_closure_use -> acc.acc_fun_action_deps <- s :: acc.acc_fun_action_deps);
138 Q.Const (label, Q.String s)
139 | _ -> e
140 ) e in
141 acc, e
142
143 let process_code_elt (rev_qml,code,env) = function
144 | Q.NewVal (label, iel)
145 | Q.NewValRec (label, iel) as code_elt ->
146 let idents = List.fold_left (fun acc (i,_) -> IdentSet.add i acc) IdentSet.empty iel in
147 let ieal =
148 List.map
149 (fun (i,e) ->
150 let acc, e = process_toplevel_binding env idents e in
151 (i, e, acc)
152 ) iel in
153 let rev_qml =
154 let l = List.map (fun (i,e,_) -> (i,e)) ieal in
155 let code_elt =
156 match code_elt with
157 | Q.NewVal _ -> Q.NewVal (label, l)
158 | Q.NewValRec _ -> Q.NewValRec (label, l)
159 | _ -> assert false in
160 code_elt :: rev_qml in
161 if List.exists (fun (_, _, acc) -> useful acc) ieal then
162 let env = IdentSet.union env idents in
163 let code = List.rev_append ieal code in
164 (rev_qml, code, env)
165 else
166 (rev_qml, code, env)
167 | _ ->
168 assert false
169
170 let process_code acc code =
171 List.fold_left process_code_elt acc code
172
173 let ident_to_string = Ident.to_string
174 (* don't care about that serialization fonction, i think *)
175
176 let runtime_code_of_accs ~server_renaming ~client_renaming accs =
177 List.map
178 (fun (i,e,acc) ->
179 let {
180 acc_rpc_deps;
181 acc_type_deps;
182 acc_rpc_def;
183 acc_type_def;
184 acc_ident_deps;
185 acc_rec_ident_deps;
186 acc_fun_action_deps
187 } = acc in
188 let defines =
189 (match acc_rpc_def, acc_type_def with
190 | [], [] -> `nothing
191 | [s], [] -> `rpc s
192 | [], [s] -> `type_ s
193 | _ ->
194 Printf.printf "ident: %s, rpc:%d, type:%d\n%!"
195 (Ident.to_string i)
196 (List.length acc_rpc_def) (List.length acc_type_def);
197 assert false
198 ) in {
199 ident = Some (ident_to_string i);
200 client_equivalent =
201 (try
202 let i = QmlRenamingMap.new_from_original client_renaming (QmlRenamingMap.original_from_new server_renaming i) in
203 let s = JsPrint.string_of_ident (JsAst.ExprIdent i) in
204 Some s
205 with Not_found -> None);
206 defines = defines;
207 ident_deps = acc_fun_action_deps @ List.map ident_to_string (IdentSet.elements (IdentSet.union acc_ident_deps acc_rec_ident_deps));
208 rpc_deps = acc_rpc_deps;
209 type_deps = acc_type_deps;
210 root = (defines = `nothing && acc_fun_action_deps = [] && is_root e)
211 }
212 ) accs
213
214 let ser_int b i =
215 (* we need to make sure that the length of an integer is fixed (or predictable at least) *)
216 (* big bytes first *)
217 for j = 64 / 8 - 1 downto 0 do
218 Buffer.add_char b (Char.chr ((i lsr (j*8)) mod 256));
219 done
220 let ser_string b s =
221 ser_int b (String.length s);
222 Buffer.add_string b s
223 let ser_option ser_a b = function
224 | None -> Buffer.add_char b '\000'
225 | Some a -> Buffer.add_char b '\001'; ser_a b a
226 let ser_list ser_a b l =
227 ser_int b (List.length l);
228 List.iter (fun a -> ser_a b a) l
229 let ser_bool b bool =
230 Buffer.add_char b (if bool then '\001' else '\000')
231
232 let ser_rpc b s =
233 (* same escaping as in qmljs_serializer! *)
234 ser_string b (JsPrint.escape_string s)
235 let ser_type b s =
236 (* same escaping as in qmljs_serializer! *)
237 ser_string b (JsPrint.escape_string s)
238 let ser_defines b = function
239 | `nothing -> Buffer.add_char b '\000'
240 | `rpc s -> Buffer.add_char b '\001'; ser_rpc b s
241 | `type_ s -> Buffer.add_char b '\002'; ser_type b s
242 let ser_ident b o =
243 ser_option ser_string b o
244 let ser_ident_deps b l =
245 ser_list ser_string b l
246 let ser_rpc_deps b l =
247 ser_list ser_rpc b l
248 let ser_type_deps b l =
249 ser_list ser_type b l
250 let ser_root = ser_bool
251 let ser_code_elt b {ident; client_equivalent; defines; ident_deps; rpc_deps; type_deps; root} =
252 (* alphabetic order of fields *)
253 ser_ident b client_equivalent;
254 ser_defines b defines;
255 ser_ident b ident;
256 ser_ident_deps b ident_deps;
257 ser_root b root;
258 ser_rpc_deps b rpc_deps;
259 ser_type_deps b type_deps
260 let ser_code b code =
261 ser_list ser_code_elt b code
262
263 let generate_register ~gamma ~stdlib_gamma ~annotmap ~val_ ~server_code =
264 let ident = val_ Opacapi.Core_server_code.register_server_code in
265 let tsc = QmlTypes.Env.Ident.find ident stdlib_gamma in
266 let ty = QmlTypes.Scheme.instantiate tsc in
267 let annotmap, fun_ = QmlAstCons.TypedExpr.ident annotmap ident ty in
268 let annotmap, string = QmlAstCons.TypedExpr.string annotmap server_code in
269 let annotmap, package = QmlAstCons.TypedExpr.string annotmap (ObjectFiles.get_current_package_name ()) in
270 let annotmap, arg = QmlAstCons.TypedExpr.record annotmap ["adhoc", string; "package_", package] in
271 let annotmap, app = QmlAstCons.TypedExpr.apply gamma annotmap fun_ [arg] in
272 let dummy_ident = Ident.next "server_ast" in
273 let tyvoid = Q.TypeRecord (Q.TyRow ([], None)) in
274 let tsc_void = QmlTypes.Scheme.quantify tyvoid in
275 let gamma = QmlTypes.Env.Ident.add dummy_ident tsc_void gamma in
276 IdentSet.singleton ident, gamma, annotmap, Q.NewVal (Annot.nolabel "pass_GenerateServerAst", [dummy_ident, app])
277
278 let _outputer oc ast =
279 let fmt = Format.formatter_of_out_channel oc in
280 Format.fprintf fmt "%a%!" pp_code ast
281
282 let process ~annotmap ~stdlib_gamma ~gamma ~val_ ~generate ~server_renaming ~client_renaming ~code =
283 match ObjectFiles.compilation_mode () with
284 | `init -> gamma, annotmap, code
285 | `prelude | `linking | `compilation ->
286 let loaded_env = R.load () in
287 let (rev_qml, acc, env) = process_code ([], [], loaded_env) code in
288 R.save ~loaded_env ~env;
289 let qml = List.rev rev_qml in
290 if generate &&
291 (try ignore (val_ Opacapi.Core_server_code.register_server_code); true
292 with Not_found -> false) then (
293 let rc = runtime_code_of_accs ~server_renaming ~client_renaming acc in
294 #<If:SERVER_SERIALIZE>
295 ignore (PassTracker.file ~filename:"serverast" _outputer rc);
296 #<End>;
297 let b = Buffer.create 1000 in
298 ser_code b rc;
299 let string = Buffer.contents b in
300 #<If:SERVER_SERIALIZE$contains "overhead">
301 Printf.printf "length: %d\n%!" (String.length string);
302 let r = ref 0 in
303 for i = 0 to String.length string - 1 do
304 if string.[i] < '\005' then incr r
305 done;
306 Printf.printf "overhead: %d, %.2f%%\n%!" !r (100. *. float !r /. float (String.length string))
307 #<End>;
308 let deps, gamma, annotmap, code_elt = generate_register ~gamma ~stdlib_gamma ~annotmap ~val_ ~server_code:string in
309 (* for the first package, we need to insert the code_elt at the end :/ *)
310 gamma, annotmap, QmlAstUtils.Code.insert ~deps ~insert:[code_elt] qml
311 ) else
312 gamma, annotmap, qml
313
314 (* FIXME:
315 the computation of roots could be finer:
316 f(x)(y) = ...
317 a = f(1) // a is considered as being a root
318 *)
Something went wrong with that request. Please try again.