-
Notifications
You must be signed in to change notification settings - Fork 125
/
opaTopEval.ml
433 lines (376 loc) · 14.4 KB
/
opaTopEval.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF mli *)
(* depends *)
module Array = Base.Array
module Format = Base.Format
module List = Base.List
(* shorthands *)
module B = BslTypes
module Q = QmlAst
module QC = QmlAstCons.UntypedExpr
module V = OpaTopValue
module P = OpaTopProperties
(* debug *)
let debug fmt =
OManager.printf ("@{<cyan>[Eval]@}@ @[<2>"^^fmt^^"@]@.")
(* Error managment *)
let fail fmt = OManager.error ("@[<2>@{<bright>Eval@}:@\n"^^fmt^^"@]@\n")
(* template *)
(*
let _ =
#<If:OPATOP_EVAL $minlevel 1>
debug "do some %s of level %d@\n" "debug" 1
#<End>
in
*)
(* printer *)
let pp =
#<If:OPATOP_ANNOT>
QmlPrint.pp_annotation
#<Else>
(QmlPrint.pp :> QmlPrint.base_printer_with_sugared_types)
#<End>
type env = V.t IdentMap.t
type ('a, 'b) ignored_directive = [
| QmlAst.type_directive
| `async
| `atomic
| `fun_action of 'a
| `nonexpansive
| `spawn
| `tracker of 'b
| `unsafe_cast
| `may_cps
| `wait
]
let rec traverse_ignore expr =
match expr with
| Q.Directive (_, #ignored_directive, [expr], _)
| Q.Coerce (_, expr, _) -> traverse_ignore expr
| _ -> expr
let make_bypass skey = QC.bypass (BslKey.normalize skey)
(* global annotmaps *)
let valueOfAnnot = ref AnnotMap.empty
let getValueOfAnnot x = AnnotMap.find_opt x !valueOfAnnot
let setValueOfAnnot x t = valueOfAnnot := AnnotMap.add x t !valueOfAnnot; ()
let resetAnnot () = valueOfAnnot := AnnotMap.empty
let (!!) pat fmt =
(* FIXME: get pos from expr *)
OManager.printf "@[<2>@{<bright>RuntimeError@}:@\nFIXME: citation instead of AST printing@\n";
OManager.printf "In the pattern %a@]@\n" pp#pat pat;
OManager.error fmt
(*
The function [match_pattern] returns an option of a new env, by adding the
bindings introduced by the pattern
If the match is unsuccessfull, the function returns [None]
*)
let rec match_pattern env pat value =
match pat, value with
| Q.PatCoerce (_, pat, _), _ -> match_pattern env pat value
| Q.PatConst (_, pc), V.V_const (_, vc) ->
if pc = vc (* Q.const_expr, Pervasives.compare *)
then Some env
else None
| Q.PatVar (_, ident), _ -> Some (IdentMap.add ident value env)
| Q.PatAny _, _ -> Some env
| Q.PatAs (_, alias_pat, ident), _ -> (
let new_env_opt = match_pattern env alias_pat value in
match new_env_opt with
| None ->
(* The aliased pattern didn't match the value, so the ident alias
is not bound. *)
None
| Some new_env ->
(* The aliased pattern matched the value. May be this induced some
bindings we must keep and we also must add a binding for the ident
alias. *)
Some (IdentMap.add ident value new_env)
)
| Q.PatRecord (_, [], rowvar), V.V_record (_, fields,_) ->
if rowvar = `open_ || StringMap.is_empty fields
then Some env
else None
| Q.PatRecord (_, pfields, rowvar), V.V_record (_, vfields, _) ->
let rec check_fields env present = function
| [] -> (
match rowvar with
| `open_ -> Some env
(* The pattern matching is closed. We must check if we have matched all the fields *)
| `closed -> (
let surjective =
StringMap.fold (fun key _ bool -> bool && StringSet.mem key present) vfields true
in
if surjective then Some env else None
)
)
| (field, p1) :: tl -> (
match StringMap.find_opt field vfields with
| None -> None
| Some value -> (
match match_pattern env p1 (Lazy.force value) with
| None -> None
| Some env -> check_fields env (StringSet.add field present) tl
)
)
in check_fields env StringSet.empty pfields
| _ -> None
let nopos = FilePos.nopos "OpaTopEval.eval"
let (!!) expr fmt =
(* FIXME: get pos from expr *)
OManager.printf "@[<2>@{<bright>RuntimeError@}:@\nFIXME: citation instead of AST printing@\n";
OManager.printf "In the expression %a@]@\n" pp#expr expr;
OManager.error fmt
let rec eval env expr =
let _ =
#<If:OPATOP_EXPR>
OManager.printf "eval(expr): %a@." pp#expr expr
#<End>
in
let main_expr = expr in
let value =
if P.noeval_get() then V.t_null ~pos:nopos ()
else match expr with
| Q.Const (label, e) -> V.V_const (Annot.pos label, e)
| Q.Ident (_, id) -> (
try
(* must be mem by type checking, but typer may be off *)
IdentMap.find id env
with
| Not_found -> !! expr "unbound value %S@\n" (Ident.to_string id)
)
| Q.LetIn (_, lets, in_) ->
let seen = ref IdentSet.empty in
let fold env (id, expr) =
if IdentSet.mem id !seen
then !! main_expr "Variable %S is bound several times in this let and@\n" (Ident.to_string id)
else (
seen := IdentSet.add id !seen ;
let value = eval env expr in
let env = IdentMap.add id value env in
env
)
in
let env = List.fold_left fold env lets in
eval env in_
| Q.LetRecIn (_, lets, in_) ->
let env =
let tmp = ref IdentMap.empty in
let fold env (id, expr) =
let value =
let lambda =
match traverse_ignore expr with
| Q.Lambda _ as expr -> expr
| _ -> !! main_expr "This kind of expression is not allowed as right-hand side of `let rec'@\n"
in
V.V_closure (Q.Pos.expr lambda, tmp, lambda)
in
setValueOfAnnot (Q.QAnnot.expr expr) value;
IdentMap.add id value env
in
let env = List.fold_left fold env lets in
tmp := env;
env
in
eval env in_
| Q.Lambda (label, _, _) -> V.V_closure (Annot.pos label, ref env, expr)
(* Apply : Be carrefully with this lines, the main idea of this version of interpreter is here *)
(* The magie is just here in case of specialisation of high functional mixity between qml & ocaml *)
(* In a simplier version (for example : no functionnal qml value of type 'a -> 'b can be passed
as an argument of type 'a of a bypass-function) the hack would be not necessary *)
| Q.Apply (_, f, args) -> (
let vf = eval env f in
let fail_arity i j =
fail "arity mismatch (expected %d, get %d), cannot apply %a in %a." i j
OpaTopValue.pp vf pp#expr main_expr in
match vf with
| V.V_closure (_, clot_env, Q.Lambda (_, ids, body)) ->
(* classic_apply : apply beta-redex with closure *)
let update_env1 clot_env id arg = IdentMap.add id (eval env arg) clot_env in
let update_env clot_env ids args =
try List.fold_left2 update_env1 clot_env ids args
with Invalid_argument "List.fold_left2" -> fail_arity (List.length ids) (List.length args);
in
eval (update_env (!clot_env) ids args) body
(* The followings line are interresting, that allow partial application of bypass,
and a shorter code for the initial binding builtins *)
| V.V_bypass (_, targs , ret, oof) -> (
let lenargsapp = List.length targs in
let lenargsty = List.length args in
if lenargsapp <> lenargsty then fail_arity lenargsapp lenargsty;
let mls = List.map2 (fun ty qml -> V.Proj.ocaml_of_t ~eval ty (eval env qml)) targs args in
let ml =
match mls with
| [] ->
let _ =
#<If:OPATOP_HOOK>
prerr_endline "eval: HOOK-03";
#<End>
in
(Obj.obj oof) ()
| _ ->
let _ =
#<If:OPATOP_HOOK>
prerr_endline "eval: HOOK-04";
#<End>
in
List.fold_left (fun func arg -> (Obj.magic func) arg) (Obj.obj oof) mls
in
let _ =
#<If:OPATOP_HOOK>
prerr_endline "eval: HOOK-05";
#<End>
in
V.Proj.t_of_ocaml ret (Obj.repr ml)
)
| _ ->
!! expr "cannot apply %a on %a. This value is not a function@\n"
V.pp vf (Format.pp_list "@ " pp#expr) args
)
| Q.Match (_, expr, pat_expr_list) ->
let v_expr = eval env expr in
let rec aux = function
| [] ->
!! main_expr "pattern match failure. the value is %a@\n" V.pp v_expr
| (pat, expr) :: tl -> (
match match_pattern env pat v_expr with
| Some env ->
eval env expr
| None -> aux tl
)
in aux pat_expr_list
| Q.Record (label, fields) ->
let fold fields (field, expr) =
let value = eval env expr in
let fields = StringMap.add field (Lazy.lazy_from_val value) fields in
fields
in
let fields = List.fold_left fold StringMap.empty fields in
V.V_record (Annot.pos label, fields, ref None)
| Q.Dot (_, expr, field) -> (
let v_expr = eval env expr in
match v_expr with
| V.V_record (_, fields, _) -> (
let lazy_value =
try
StringMap.find field fields
with
| Not_found ->
!! expr "this record has no field %S\n(maybe the typer is off)@\n" field
in
Lazy.force lazy_value
)
| v ->
!! main_expr "in dot field %S : expected a record@ but got %a@\n" field V.pp v
)
(* { field = expr } :: expr *)
| Q.ExtendRecord (_, field, expr, record) -> (
let v_expr = eval env expr in
let v_record = eval env record in
match v_record with
| V.V_record (pos, fields, _) ->
let value = Lazy.lazy_from_val v_expr in
let fields = StringMap.add field value fields in
(* FIXME: merge with the pos from the main_expr *)
V.V_record (pos, fields, ref None)
| _ ->
!! main_expr "extend record { %s = %a } :: %a@ expected a record@\n"
field V.pp v_expr V.pp v_record
)
(* FIXME: remove this directive, change the type of the Bypass node *)
(* TODO: and get back the check of restriction in this case *)
| Q.Directive (_, `restricted_bypass _, [Q.Bypass (_, key)], _)
| Q.Bypass (_, key) -> (
(* get the cached bypass map *)
let bypass_map = OpaTopBsl.bypass_map () in
match OpaTopBsl.find_opt key bypass_map with
| Some bypass -> (
match OpaTopBsl.eval bypass with
| Some value -> value
| None -> (
!! expr "This external primitive is not available in opatop@\n"
)
)
| None ->
!! expr "Unknow external primitive. Maybe do you want to use a plugin ?@\n"
)
| Q.Path _ ->
!! expr "Presence of a raw database reading node not resolved by DbGen@\n"
| Q.Directive (_, `fail, message, _) -> (
match message with
| [] ->
!! expr "@@fail@\n"
| message :: _ ->
let message =
match eval env message with
| V.V_const (_, Q.String message) -> message
| v -> !! expr "@@fail expects one argument of type string but got: %a@\n" V.pp v
in
!! expr "@@fail: %s@\n" message
)
| Q.Directive (_, `assert_, [cond], _) -> (
let void = V.Proj.t_void () in
if not (P.assert_get ()) then void else
let v_cond = eval env cond in
match v_cond with
| V.V_record (_, fields, _) ->
(* Keep in sync with qml semantic *)
if (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) then void
else !! expr "assert failure"
| _ ->
!! expr "assert condition not a bool value: %a@\n"
V.pp v_cond
)
| Q.Directive (_, `create_lazy_record, exprs, _) -> (
let expr, o = QmlDirectives.create_lazy_record_arguments exprs in
match expr with
| Q.Record (_, fields) ->
let embed_data = Option.map (eval env) o in
let fold fields (field, expr) =
let lazy_value = lazy (eval env expr) in
StringMap.add field lazy_value fields in
let fields = List.fold_left fold StringMap.empty fields in
V.V_record (nopos, fields, ref embed_data)
| _ -> assert false
)
| Q.Directive (_, `callcc, [expr], _) ->
let fake_bypass = make_bypass "bslcps.notcps_compatibility.callcc_directive" in
let expr = QC.apply fake_bypass [expr] in
eval env expr
| Q.Directive (label, `llarray, exprs, _) ->
let len = ref 0 in
let rev_exprs = List.rev_map (fun e -> incr(len); eval env e) exprs in
let array = Array.unsafe_create !len in
let pred_len = pred !len in
let iteri v i = let i = pred_len - i in array.(i) <- v in
List.iteri iteri rev_exprs ;
let string = "llarray" in
let args = [ B.TypeVar (Annot.pos label, B.TypeVar.next()) ] in
OpaTopValue.Proj.t_extern string args array
(* ignored nodes *)
| Q.Directive (_, #ignored_directive, [expr], _)
| Q.Coerce (_, expr, _) -> eval env expr
| Q.Directive (_, d, e, t) ->
!! expr "Directive %a is not available in qmltop"
(fun fmt () -> pp#directive fmt d e t) ()
in
let annot = Q.QAnnot.expr main_expr in
let _ =
#<If:OPATOP_EXPR>
OManager.printf "value: (%a : § %d)@." OpaTopValue.pp value (Annot.to_int annot)
#<End>
in
(* Store the value in the map *)
setValueOfAnnot annot value;
value