Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 354 lines (298 sloc) 14.385 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 (*
19 FIXME:
20 1) remove open
21 2) use ocaml ast instead of verbatim
22 NO. There are still too many missing features.
23 -- module RRequest = Qos.Ressource(
24 -- for ... do etc...
25 *)
26 module B = Base
27 let (<|) f a = f a
28 let (|>) a f = f a
29 let ( @* ) g f x = g(f(x))
30 module O = Ocaml
31 module Cons = O.Cons
32 module G = Grammar
33 module T = Tools
34 module L = B.List
35
36 exception NoStateDefined
37
38 (*let str_of_expr te = let b = Buffer.create 1024 in (OcamlPrint.Buf.expr b te; Buffer.contents b)*)
39
40 (* Note: the <CR> is essential because ppdebug.pl is line-based. *)
41 let ifstr = function
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
42 | Some level -> Printf.sprintf "#<If$minlevel %d>" level
fccc685 Initial open-source release
MLstate authored
43 | None -> "#<If>"
44
45 let os s_opt = Option.default "" s_opt
46
47 let wrapexnverb exnwrap exnname verb =
48 if exnwrap
49 then Printf.sprintf "(try (%s) with exn -> _err_cont (exn,%s,if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None) _runtime sched conn _mailbox _err_cont)" verb (os exnname)
50 else verb
51
52 let verbstr (dbg,level,exnwrap,exnname,verb) =
53 let verb = wrapexnverb exnwrap exnname verb in
54 match dbg with
55 | Some "debug" -> (ifstr level)^verb^"#<End>\n"
56 | Some "release" -> (ifstr level)^"()#<Else>()"^verb^"\n#<End>\n"
57 | _ -> verb
58
59 let wrapexnexpr exnwrap exnname expr =
60 if exnwrap
61 then O.Try (expr,[(O.PatVar(Ident.source "exn"),None,
62 O.make_AppL ([O.make_Var "_err_cont";
63 (O.Tuple [O.make_Var "exn";
64 Cons.string (os exnname);
65 O.Verbatim "(if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None)";
66 ]);
67 O.make_Var "_runtime"; O.make_Var "sched";
68 O.make_Var "conn"; O.make_Var "_mailbox"; ]))])
69 else expr
70
71 let dbgexpr (dbg,level,exnwrap,exnname,expr) =
72 let expr = wrapexnexpr exnwrap exnname expr in
73 match dbg with
74 | Some "debug" -> Cons.sequence [O.Verbatim ((ifstr level)^"()"); expr; O.Verbatim "#<End>\n"]
75 | Some "release" -> Cons.sequence [O.Verbatim ((ifstr level)^"()#<Else>()"); expr; O.Verbatim "#<End>\n"]
76 | _ -> expr
77
78 let make_pv x = O.PatVar (Ident.source x)
79
80 let make_App app = function
81 | G.Ocaml (dbg,l,ew,en,e) -> O.App (app, (dbgexpr (dbg,l,ew,en,e)))
82 | G.GVerbatim (dbg,l,ew,en,s) -> O.App (app, O.Verbatim (verbstr (dbg,l,ew,en,s)))
83 | _ -> assert false
84
85 let make_fp = function
86 | G.GVar (str, _type) -> O.Pat (O.PatVar (Ident.source str))
87 | _ -> assert false
88
89 let rec make_pat = function
90 | G.Underscore -> O.PatAny
91 | G.Ident s -> O.PatVar (Ident.source s)
92 | G.Constr (name, params) ->
93 O.PatConstructor (
94 [Ident.source name] ,
95 L.map (make_pv @* fst) <| L.map T.tuple_of_var params
96 )
97 | _ -> assert false
98
99 and rewrite_clause = function
100 | G.Case ((constr, guard), code) ->
101 let pattern = make_pat constr in
102 let guard = Option.map (
103 function
104 | (G.Ocaml (dbg,l,ew,en,x)) -> dbgexpr (dbg,l,ew,en,x)
105 | (G.GVerbatim (dbg,l,ew,en,x)) -> O.Verbatim (verbstr (dbg,l,ew,en,x))
106 | _ -> assert false
107 ) guard in
108 pattern, guard, rewrite_code code
109 | _ -> assert false
110
111 and receive rfn success errors timeout =
112
113 let make_err_cont clauses timeout =
114 let clauses = match timeout with
115 | None -> clauses
116 | Some (G.Timeout ( _, what_to_do)) ->
117 let clause = G.Case ((G.Constr ("Timeout", []), None), what_to_do) in
118 clause :: clauses
119 | _ -> assert false in
120 let clauses =
121 match L.map rewrite_clause clauses with
122 | [] -> [O.PatAny, None, O.Const O.Unit]
123 | [((O.PatConstructor ([timeout], _) as patconst), g, re)] when Ident.stident timeout = "Timeout" ->
124 (patconst, g, re) :: [O.PatAny, None, O.Const O.Unit]
125 | otherwise -> otherwise
126 in O.Var (
127 O.Labeled (
128 "err_cont" ,
129 Some ( O.Function ( clauses ) )
130 )
131 )
132 in
133
134 let get_timeout = function
135 | None -> []
136 | Some (G.Timeout (float, _)) ->
137 [O.Var (O.Labeled ("timeout", Some (O.Verbatim float)))]
138 | _ -> assert false in
139
140 let apps = O.Verbatim rfn
141 :: make_err_cont errors timeout
142 :: get_timeout timeout
143 @[ success ]
144 in
145
146 O.make_AppL apps
147
148 and make_recv rfn v vstr clst elst timeout tail =
149 let success = O.Abs ([O.pf "v"], O.Match (O.make_Var "v", L.map rewrite_clause clst)) in
150 let recv = receive rfn success elst timeout in
151 O.Letin ([(O.pf vstr, v)],
152 (match tail with
153 | [] -> recv
154 | lst -> O.Sequence (recv, rewrite_code lst)))
155
156 and rewrite_code = function
157 | [] -> O.Const O.Unit
158
159 | G.Block lst::tail -> O.Sequence (rewrite_code lst, rewrite_code tail)
160
161 | G.Close::lst ->
162 (*let close = O.Verbatim "Scheduler.remove_connection sched conn" in*)
163 let close = O.Verbatim "close_conn sched conn _mailbox" in
164 (match lst with [] -> close | _ -> O.Sequence (close, rewrite_code lst))
165
166 | G.Call (n,params)::lst ->
167 if (not <| L.is_empty lst) then
168 raise <| T.Operation_after_statecall n
169 else L.fold_left make_App (O.Verbatim ("proto_" ^ n)) (params @ [G.GVerbatim (None,None,false,None,"_runtime");
170 G.GVerbatim (None,None,false,None,"sched");
171 G.GVerbatim (None,None,false,None,"conn");
172 G.GVerbatim (None,None,false,None,"_mailbox");
173 G.GVerbatim (None,None,false,None,"_err_cont");
174 ])
175
176 | G.GLet (var, G.Async (exnwrap,exnname,expr))::tail ->
177 O.App (
178 O.Abs([O.pf "__proto_temp_cont"],
179 wrapexnexpr exnwrap exnname (O.App (expr,O.make_Var "__proto_temp_cont"))),
180 O.Abs ([O.Pat (O.PatVar (Ident.source (fst <| T.tuple_of_var var)))],
181 rewrite_code tail))
182
183 | G.GLet (var, G.Ocaml (dbg,level,exnwrap,exnname,value))::tail ->
184 wrapexnexpr exnwrap exnname (O.Letin ([make_fp var, dbgexpr (dbg,level,false,None,value)], rewrite_code tail))
185
186 | G.GLet (var, G.GVerbatim (dbg,level,exnwrap,exnname,value))::tail ->
187 wrapexnexpr exnwrap exnname (O.Letin ([make_fp var, O.Verbatim (verbstr (dbg,level,false,None,value))], rewrite_code tail))
188
189 | G.Errcont fn::tail ->
190 O.Letin ([O.pf "_err_cont", O.App (O.make_Var "ecsa2ec",O.make_Var ("proto_"^fn))], rewrite_code tail)
191
192 | G.Ocaml (dbg,l,ew,en,e)::tail -> (match tail with
193 | [] -> dbgexpr (dbg,l,ew,en,e)
194 | _ -> wrapexnexpr ew en (O.Sequence (dbgexpr (dbg,l,false,None,e), rewrite_code tail)))
195
196 (*| G.OcamlTop sl::tail -> NO!!!
197 Cons.sequence (sl@(match tail with | [] -> [] | _ -> [rewrite_code tail]))*)
198
199 | G.GVerbatim (dbg,l,ew,en,s)::tail -> (match tail with
200 | [] -> O.Verbatim (verbstr (dbg,l,ew,en,s))
201 | _ -> wrapexnexpr ew en (O.Sequence (O.Verbatim (verbstr (dbg,l,false,None,s)), rewrite_code tail)))
202
203 | G.If (G.Ocaml (_,_,_,_,c), G.Block t, G.Block e)::tail ->
204 let cond = O.Cond (c, rewrite_code t, rewrite_code e)
205 in (match tail with [] -> cond | _ -> O.Sequence (cond, rewrite_code tail))
206
207 | G.If (G.GVerbatim (_,_,_,_,c), G.Block t, G.Block e)::tail ->
208 let cond = O.Cond (O.Verbatim c, rewrite_code t, rewrite_code e)
209 in (match tail with [] -> cond | _ -> O.Sequence (cond, rewrite_code tail))
210
211 | G.GMatch (ew, en, e, pelst)::tail ->
212 (* TODO: implement guards *)
213 let mtch = O.Match (e, L.map (function ((g,p),G.Block e) -> (p,g,rewrite_code e) | _ -> assert false) pelst) in
214 wrapexnexpr ew en
215 (match tail with
216 | [] -> mtch
217 | _ -> O.Sequence (mtch, rewrite_code tail))
218
219 | G.Send msg::tail ->
220 O.App (
221 O.App (
222 (O.Verbatim "write_errcont _runtime sched conn"),
223 (O.App (O.Verbatim "string_of_msg", O.Verbatim msg))),
224 O.Abs ([O.Pat O.PatAny], rewrite_code tail)
225 )
226
227 | G.SendBuf buf::tail ->
228 O.App (
229 O.App (
230 (O.Verbatim "write_errcont _runtime sched conn"), buf),
231 O.Abs ([O.Pat O.PatAny], rewrite_code tail)
232 )
233
234 | G.Listen (var, port_spec_exp, fn)::tail ->
235 let fnstr = String.concat " " fn in
236 let l = O.Letin ([(O.Pat (O.PatTuple [O.PatVar (Ident.source "port_spec"); O.PatVar (Ident.source "sec_mode")]), port_spec_exp)],
237 O.Verbatim ("Network.listen sched port_spec sec_mode (fun _ conn2 -> proto_"
238 ^fnstr^" _runtime sched conn2 (new_mailbox _runtime) _err_cont)")) in
239 O.Letin ([(make_fp var),l],rewrite_code tail)
240
241 | G.ReadConn (var,conn_blk)::tail ->
242 O.Letin ([(O.Pat (O.PatTuple [O.PatVar (Ident.source "conn2"); O.PatVar (Ident.source "_blksize")]), O.Verbatim conn_blk)],
243 (O.App (O.Verbatim "Scheduler.read sched conn2 ",
244 O.Abs ([make_fp var], rewrite_code tail))))
245
246 | G.WriteConn conn_msg::tail ->
247 O.App (
248 O.Letin ([(O.Pat (O.PatTuple [O.PatVar (Ident.source "conn2"); O.PatVar (Ident.source "msg")]),
249 O.Verbatim conn_msg)],
250 O.Verbatim "write_errcont _runtime sched conn2 msg"),
251 O.Abs ([O.Pat O.PatAny], rewrite_code tail)
252 )
253
254 (*| G.Sleep time::tail ->
255 O.App (O.Letin ([(O.Pat (O.PatVar (Ident.source "time")), time)],
256 O.Verbatim "(fun cont -> ignore (Scheduler.sleep sched time cont))"),
257 O.Abs ([O.Pat O.PatAny], rewrite_code tail))*)
258
259 | G.Connect (port_spec_exp, fn)::tail ->
260 let fnstr = String.concat " " fn in
261 let l =
262 O.Letin ([(O.Pat (O.PatTuple [O.PatVar (Ident.source "port_spec"); O.PatVar (Ident.source "sec_mode")]), port_spec_exp)],
263 O.Verbatim ("Network.connect sched port_spec sec_mode (fun conn2 -> proto_"
264 ^fnstr^" conn2 _runtime sched conn _mailbox _err_cont)")) in
265 (match tail with
266 | [] -> l
267 | _ -> O.Sequence (l, rewrite_code tail))
268
269 | G.SendAll lst::tail ->
270 O.Sequence (
271 O.App ( O.App (
272 O.Verbatim "List.iter",
273 O.Abs ([O.Pat (O.PatVar (Ident.source "msg"))],
274 O.App ( O.App (
275 O.Verbatim "write_errcont _runtime sched conn",
276 O.App (O.Verbatim "string_of_msg", O.Verbatim "msg")),
277 O.Abs ([O.Pat O.PatAny], O.Const O.Unit)))),
278 O.Verbatim lst),
279 rewrite_code tail)
280
281 | G.Receive (_, _, clst, elst, timeout)::tail ->
282 let rfn = "receive _runtime sched conn _mailbox" in
283 let success =
284 O.Function (L.map rewrite_clause clst)
285 (*
286 O.Abs (
287 [O.pf "msg"],
288 (*[O.Pat (O.PatConst O.Unit)] ,*)
289 O.Match (
290 (*O.Verbatim "Queue.pop (getmb _mailbox)" ,*)
291 O.make_Var "msg",
292 L.map rewrite_clause clst
293 )
294 )
295 *)
296 in
297 let receive = receive rfn success elst timeout in
298 (match tail with
299 | [] -> receive
300 | lst -> O.Sequence (receive, rewrite_code lst))
301
302 | G.Upto (mark, clst, elst, timeout)::tail ->
303 (*let rfn = "HttpTools.read_upto_stream_cps ~inclusive:false _runtime.rt_buf (getmbox conn _mailbox) mark sched" in*)
304 let rfn = "HttpTools.upto_mark_stream_cps3 ~inclusive:false sched conn _mailbox mark ?callback:_runtime.rt_tmp.rt_callback _runtime.rt_proto.rt_payload ~blocksize:_runtime.rt_proto.rt_block_size" in
305 make_recv rfn mark "mark" clst elst timeout tail
306
307 | G.Fixed (cnt, clst, elst, timeout)::tail ->
308 (*let rfn = "HttpTools.read_fixed_stream_cps _runtime.rt_buf (getmbox conn _mailbox) cnt sched" in*)
309 let rfn = "HttpTools.fixed_stream_cps3 sched conn _mailbox cnt ?callback:_runtime.rt_tmp.rt_callback _runtime.rt_proto.rt_payload ~blocksize:_runtime.rt_proto.rt_block_size" in
310 make_recv rfn cnt "cnt" clst elst timeout tail
311
312 | G.Content (content, clst, elst, timeout)::tail ->
313 let rfn = "Scheduler.read_content sched conn content " in
314 make_recv rfn content "content" clst elst timeout tail
315
316 | G.ReadRaw (clst, elst, timeout)::tail ->
317 let rfn = "Scheduler.read sched conn " in
318 make_recv rfn Cons.unit "()" clst elst timeout tail
319
320 | G.Sleep time_expr::tail ->
321 O.App (O.Letin ([(O.pf "time" , time_expr)],
322 O.Verbatim ("(fun c -> ignore (Scheduler.sleep sched time c))")),
323 O.Abs ([O.Pat O.PatAny], rewrite_code tail))
324
325 |_ -> assert false
326
327
328 let rewrite_fun f =
329 let make_fun (n, params, b) =
330 try
331 O.Pat (O.PatVar (Ident.source ("proto_" ^ n))),
332 O.Abs (
333 (L.map make_fp params) @ [O.Pat (O.PatVar (Ident.source " _runtime"));
334 O.Pat (O.PatVar (Ident.source " sched"));
335 O.Pat (O.PatVar (Ident.source " conn"));
336 O.Pat (O.PatVar (Ident.source " _mailbox"));
337 O.Pat (O.PatVar (Ident.source " _err_cont"));
338 ],
339 rewrite_code b
340 )
341 with
342 | T.Operation_after_statecall s ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
343 Printf.sprintf "Error in state ' %s ' : no operation can be done after going to state : %s" n s
fccc685 Initial open-source release
MLstate authored
344 |> failwith
345 | e -> raise e
346 in match f with
347 | Reorder_functions.Rec (lst) -> O.Letrec (L.map make_fun lst)
348 | Reorder_functions.Normal (n,p,b) -> O.Let ([make_fun (n,p,b)])
349
350 (* Generating functions *)
351 let gen_funs = function
352 | [] -> raise NoStateDefined
353 | lst -> L.rev_map rewrite_fun <| Reorder_functions.do_it lst
Something went wrong with that request. Please try again.