-
Notifications
You must be signed in to change notification settings - Fork 125
/
pass_CompileRecursiveValues.ml
423 lines (390 loc) · 18.1 KB
/
pass_CompileRecursiveValues.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
(*
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/>.
*)
module Q = QmlAst
module List = BaseList
module Format = BaseFormat
module IdentAssoc = List.MakeAssoc(Ident)
exception InvalidRecursion
module Warning = struct
let recval =
let doc = "Recursive values" in
WarningClass.create ~name:"recval" ~doc ~err:true ~enable:true ()
let recval_lambda =
let doc = "Recursive value as a lambda - deprecated in js-like syntax (S4)" in
WarningClass.create ~parent:recval ~name:"lambda" ~doc ~err:true ~enable:true ()
let set = WarningClass.Set.create_from_list [
recval;
recval_lambda;
]
end
let warning_set = Warning.set
let map_intersection merge_value map1 map2 =
IdentMap.fold
(fun k v1 acc ->
try let v2 = IdentMap.find k map2 in
IdentMap.add k (merge_value v1 v2) acc
with Not_found ->
acc
) map1 IdentMap.empty
(* this function takes a binding (from a recursive set of bindings)
* and distinguishes 3 cases:
* - the expression is tagged with @recval (coming from rec val or and val in the syntax)
* returns Some of a map from the direct dependencies of this expression on the other
* identifiers of the bindings of their positions
* - the expression is a lambda -> return None
* - in other cases, the recursion is invalid, and the InvalidRecursion is raised
*)
let is_a_val_binding idents (_i, e) =
let merge_value = (@) in
let find_deps e =
QmlAstWalk.Expr.self_traverse_fold
(fun self tra deps e ->
match e with
| Q.Ident (label, i) when IdentSet.mem i idents -> IdentMap.add i [Annot.pos label] deps
| Q.Match (_, e, pel) -> (
let deps = self deps e in
let depss = List.map (fun (_p,e) -> self IdentMap.empty e) pel in
match depss with
| [] -> assert false
| h :: t ->
(* we can sure that we depend on an identifier only if all the
* branches depend on that identifier
* hence we must take the intersection of the dependencies of the branches
* and NOT their union *)
let intersection = List.fold_left (map_intersection merge_value) h t in
IdentMap.merge merge_value intersection deps
)
| Q.Lambda _ ->
deps
| _ ->
tra deps e
) IdentMap.empty e in
let rec is_a_val = function
| Q.Lambda _ -> None
| Q.Directive (_, `recval, [e], _) ->
(* TODO *)
(* checking that you don't put a val rec on a function *)
(try match is_a_val e with
| None ->
let context = QmlError.Context.expr e in
QmlError.warning ~wclass:Warning.recval_lambda context
"This expression is a function, it can be recursive without being tagged with 'val'.";
Some (find_deps e)
| Some _ -> Some (find_deps e)
with InvalidRecursion -> Some (find_deps e));
| Q.Directive (_, `recval, _, _) -> assert false
| Q.Coerce (_, e, _)
(* BEWARE before editing: keep this set of directive in sync with the one
* in remove_toplevel_directives *)
| Q.Directive (_, (#Q.type_directive | #Q.binding_directive), [e], _) -> is_a_val e
| _ -> raise InvalidRecursion in
is_a_val e
let lazy_type gamma var =
let typeident = Q.TypeIdent.of_string Opacapi.Types.finite_single_thread_lazy in
let (typeident, _) = QmlTypes.Env.TypeIdent.findi ~visibility_applies:true typeident gamma in
(* grabbing the typeident from the gamma, or else we might have the infamous
* assert failure somewhere in the typer saying "call type_of_type" *)
Q.TypeName ([var], typeident)
let lazy_force_type gamma var =
Q.TypeArrow ([lazy_type gamma var], var)
let mutable_make_type gamma ty =
let var = QmlAstCons.Type.next_var () in
Q.TypeArrow ([var], lazy_type gamma ty)
let mutable_set_type gamma ty =
Q.TypeArrow ([lazy_type gamma ty; ty], Q.TypeRecord (Q.TyRow ([], None)))
let force ~val_ gamma annotmap label lazy_i =
let lazy_force = val_ Opacapi.FiniteSingleThreadLazy.force in
let ty = QmlAnnotMap.find_ty_label label annotmap in
let annotmap, force = QmlAstCons.TypedExpr.ident annotmap lazy_force (lazy_force_type gamma ty) in
let annotmap, lazy_i_expr = QmlAstCons.TypedExpr.ident annotmap lazy_i (lazy_type gamma ty) in
let annotmap, forced_lazy = QmlAstCons.TypedExpr.apply gamma annotmap force [lazy_i_expr] in
annotmap, forced_lazy
let partition_map p l =
let rec aux acc1 acc2 = function
| [] -> List.rev acc1, List.rev acc2
| h :: t ->
match p h with
| None -> aux acc1 (h :: acc2) t
| Some v -> aux ((h, v) :: acc1) acc2 t in
aux [] [] l
let rec drop_until p = function
| [] -> None, []
| h :: t ->
if p h then
Some h, t
else
drop_until p t
(* simple check to reject at compile time some cases of illegal value recursion
* such as [val rec x = x] *)
let check_lack_of_cycle val_deps_bindings =
let val_deps = List.map (fun ((i,_e),deps) -> (i,deps)) val_deps_bindings in
let pos_of_def i =
let (_, e), _ = List.find (fun ((j,_),_) -> Ident.equal i j) val_deps_bindings in
Q.Pos.expr e in
let rec aux occur i posl =
if IdentAssoc.mem i occur then (
(* the dependencies that cause the immediate loop *)
let calls = List.rev ((i,posl) :: occur) in
(* the relevant part of the dependencies *)
let _, calls = drop_until (fun (j,_) -> Ident.equal i j) calls in
OManager.serror "@[<v>%a@]@\n@[<v2>Invalid recursive value binding: @{<bright>%s@} depends on itself@]@\n@[<v2>Hint:@ Here is the chain of immediate dependencies:@ %a@]"
FilePos.pp (pos_of_def i)
(Ident.original_name i)
(Format.pp_list "@\n"
(fun f (i,posl) ->
(* we have several positions when there are branching,
* but perhaps it gives too much information to show all
* the positions *)
let pos = List.hd posl in
Format.fprintf f "@[<v2>%s at %a@]" (Ident.original_name i) FilePos.pp pos
)) calls;
(* exiting to give only one error message in the recursive group *)
raise InvalidRecursion
) else
let occur = (i,posl) :: occur in
(* only non lambda bindings are in val_deps, so we can get a Not_found here *)
let deps = try IdentAssoc.find i val_deps with Not_found -> IdentMap.empty in
IdentMap.iter (aux occur) deps in
try
List.iter
(fun (i,_) -> aux [] i [])
val_deps
with InvalidRecursion -> ()
let move_ei_tsc_gen label annotmap e =
let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
assert (QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr e) annotmap = None);
QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr e) tsc_gen_opt annotmap
(* now the typing directive are just freaking annoying, because there may be
* more slicer directives under them so let's remove them *)
let remove_toplevel_directives annotmap e =
let rec aux dirs annotmap = function
| Q.Coerce (label, e, _)
| Q.Directive (label, #Q.type_directive, [e], _) ->
let annotmap = move_ei_tsc_gen label annotmap e in
aux dirs annotmap e
| Q.Directive (label, (#Q.binding_directive as v), [e], []) ->
let annotmap = move_ei_tsc_gen label annotmap e in
aux (v :: dirs) annotmap e
| Q.Directive (_, #Q.slicer_directive, _, _) -> assert false
| e -> annotmap, dirs, e in
aux [] annotmap e
let rec put_back_toplevel_directives annotmap dirs e =
match dirs with
| [] -> annotmap, e
| dir :: dirs ->
let label = Q.Label.expr e in
let new_label = Annot.refresh label in
let ty = QmlAnnotMap.find_ty_label label annotmap in
let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
let annotmap = QmlAnnotMap.remove_tsc_label label annotmap in
let annotmap = QmlAnnotMap.add_ty_label new_label ty annotmap in
let annotmap = QmlAnnotMap.add_tsc_opt_label new_label tsc_gen_opt annotmap in
let e = Q.Directive (new_label, dir, [e], []) in
put_back_toplevel_directives annotmap dirs e
(*
* rewrites [rec val x = e1
* and f() = e2]
* into
* [lazy_x = mutable_make(0)
* rec f() = e2[lazy_force(lazy_x) / x ]
* _ = mutable_set(lazy_x, ( -> e1[lazy_force(lazy_x) / x ]))
* x = lazy_force(lazy_x)
* ]
* The only expressions in the recursive bindings after this rewriting are lambdas
* (modulo coercions, some directives, etc.)
*)
let process_bindings ~val_ gamma annotmap bindings =
let idents = List.fold_left (fun acc (i,_) -> IdentSet.add i acc) IdentSet.empty bindings in
let invalid_bindings = ref [] in
let val_deps_bindings, fun_bindings =
partition_map
(fun b ->
try is_a_val_binding idents b
with InvalidRecursion ->
invalid_bindings := b :: !invalid_bindings;
None
) bindings in
if !invalid_bindings <> [] then (
(match bindings with
| [(i,e)] ->
(* a more concise error message in the common case of not mutual recursion *)
let context = QmlError.Context.expr e in
QmlError.serror context "@[<v2> The recursive definition of @{<bright>%s@} is invalid." (Ident.original_name i)
| _ ->
OManager.serror "@[<v2>In the recursive group consisting of {@[<h>%a@]}, the following recursive definitions are invalid:@\n%a@]@\n@]"
(Format.pp_list ",@ " (fun f i -> Format.pp_print_string f (Ident.original_name i))) (IdentSet.elements idents)
(Format.pp_list "@ " (fun f (i,e) -> Format.fprintf f "@{<bright>%s@} at %a" (Ident.original_name i) FilePos.pp (Q.Pos.expr e))) !invalid_bindings
);
None
) else (
check_lack_of_cycle val_deps_bindings;
let val_bindings = List.map fst val_deps_bindings in
if val_bindings = [] then
None
else (
let mutable_make = val_ Opacapi.Mutable.make in
let mutable_set = val_ Opacapi.Mutable.set in
(* when we write @server rec val x = ..., then we remove the directive
* @server from the body of x and we will put it on all the toplevel
* bindings generated from x *)
let annotmap, val_bindings =
List.fold_left_map
(fun annotmap (i,e) ->
let annotmap, dirs, e = remove_toplevel_directives annotmap e in
annotmap, (i, e, dirs)
) annotmap val_bindings in
let lazy_idents = List.map (fun (i,_,_) -> Ident.refreshf ~map:"lazy_%s" i) val_bindings in
let annotmap, lazy_defs =
List.fold_left_map2
(fun annotmap i (_,e,dirs) ->
let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
let annotmap, mutable_make = QmlAstCons.TypedExpr.ident annotmap mutable_make (mutable_make_type gamma ty) in
(* could put a well typed value if needed (like {evaluating}) *)
let annotmap, zero = QmlAstCons.TypedExpr.int annotmap 7 in
let annotmap, def = QmlAstCons.TypedExpr.apply gamma annotmap mutable_make [zero] in
let annotmap, def = put_back_toplevel_directives annotmap dirs def in
annotmap, (i, def)
) annotmap lazy_idents val_bindings in
let annotmap, lazy_sets =
List.fold_left_map2
(fun annotmap i (_, e, dirs) ->
let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
let annotmap, mutable_set = QmlAstCons.TypedExpr.ident annotmap mutable_set (mutable_set_type gamma ty) in
let annotmap, lambda = QmlAstCons.TypedExpr.lambda annotmap [] e in
let annotmap, lazy_body = QmlAstCons.TypedExpr.sum_element annotmap ["delayed", lambda] in
let annotmap, ref_ = QmlAstCons.TypedExpr.ident annotmap i (lazy_type gamma ty) in
let annotmap, set = QmlAstCons.TypedExpr.apply gamma annotmap mutable_set [ref_; lazy_body] in
let annotmap, set = put_back_toplevel_directives annotmap dirs set in
annotmap, (Ident.next "set_lazy", set)
) annotmap lazy_idents val_bindings in
let annotmap, original_bindings =
List.fold_left_map2
(fun annotmap lazy_i (i, e, dirs) ->
let annotmap, forced_lazy = force ~val_ gamma annotmap (Q.Label.expr e) lazy_i in
let annotmap, forced_lazy = put_back_toplevel_directives annotmap dirs forced_lazy in
annotmap, (i, forced_lazy)
) annotmap lazy_idents val_bindings in
let assoc_ident = List.map2 (fun lazy_i (i,_,_) -> (i,lazy_i)) lazy_idents val_bindings in
let rewrite_binding annotmap (i,e) =
let annotmap, e = QmlAstWalk.Expr.traverse_foldmap
(fun tra annotmap e ->
match e with
| Q.Ident (label, i) -> (
try
let lazy_i = IdentAssoc.find i assoc_ident in
force ~val_ gamma annotmap label lazy_i
with Not_found ->
annotmap, e
)
| _ -> tra annotmap e
) annotmap e in
annotmap, (i, e) in
let rewrite_bindings annotmap l =
List.fold_left_map rewrite_binding annotmap l in
let annotmap, lazy_sets = rewrite_bindings annotmap lazy_sets in
let annotmap, fun_bindings = rewrite_bindings annotmap fun_bindings in
Some (
annotmap,
lazy_defs,
(if fun_bindings = [] then None else Some fun_bindings),
lazy_sets,
original_bindings
)
)
)
let process_bindings_for_toplevel ~val_ gamma annotmap label bindings =
match process_bindings ~val_ gamma annotmap bindings with
| None ->
None
| Some (annotmap, lazy_defs, fun_bindings_opt, lazy_sets, original_bindings) ->
let code =
Q.NewVal (Annot.refresh label, lazy_sets) ::
Q.NewVal (Annot.refresh label, original_bindings) ::
[] in
let code =
match fun_bindings_opt with
| None -> code
| Some fun_bindings -> Q.NewValRec (Annot.refresh label, fun_bindings) :: code in
let code = Q.NewVal (Annot.refresh label, lazy_defs) :: code in
let add_to_gamma gamma bindings =
List.fold_left
(fun gamma (i,e) ->
let tsc = QmlTypes.Scheme.quantify (QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap) in
QmlTypes.Env.Ident.add i tsc gamma
) gamma bindings in
let gamma = add_to_gamma gamma lazy_defs in
let gamma = add_to_gamma gamma lazy_sets in
Some (gamma, annotmap, code)
let process_code ~val_ gamma annotmap code =
(* rewriting newvalrec *)
let (gamma, annotmap), code =
List.fold_left_collect
(fun (gamma, annotmap) c ->
match c with
| Q.NewValRec (label, bindings) -> (
match process_bindings_for_toplevel ~val_ gamma annotmap label bindings with
| None -> (gamma, annotmap), [c]
| Some (gamma, annotmap, code) -> (gamma, annotmap), code
)
| _ -> (gamma, annotmap), [c]
) (gamma, annotmap) code in
(* rewriting letrec and removing @recval *)
let annotmap, code =
QmlAstWalk.CodeExpr.fold_map
(QmlAstWalk.Expr.self_traverse_foldmap
(fun self tra annotmap e ->
match e with
| Q.LetRecIn (label, bindings, e_in) -> (
match process_bindings ~val_ gamma annotmap bindings with
| None -> tra annotmap e
| Some (annotmap, lazy_defs, fun_bindings_opt, lazy_sets, original_bindings) ->
let label2 = Annot.refresh label in
let label4 = Annot.refresh label in
let label5 = Annot.refresh label in
(* not copying the information for ei *)
let ty = QmlAnnotMap.find_ty_label label annotmap in
let annotmap = QmlAnnotMap.add_ty_label label2 ty annotmap in
let annotmap = QmlAnnotMap.add_ty_label label4 ty annotmap in
let annotmap = QmlAnnotMap.add_ty_label label5 ty annotmap in
let e_in =
Q.LetIn (label2, lazy_sets,
Q.LetIn (label, original_bindings, e_in)) in
let e_in =
match fun_bindings_opt with
| None -> e_in
| Some fun_bindings -> Q.LetRecIn (label4, fun_bindings, e_in) in
let e_in =
Q.LetIn (label5, lazy_defs, e_in) in
(* need to go down to rewrite e_in and lazy_sets
* (although we could just rewrite them instead of calling ourselves
* recursively on the term produced) *)
tra annotmap e_in
)
| Q.Directive (label, `recval, [e], []) ->
(* it is possible that we have a recval on a let that is not recursive
* for instance when we say [rec val x = 1] because the dependency analysis
* will transform newvalrec and letrec into newval and letin if possible
* also other rewriting (such as the one for let pattern = expr in expr)
* may duplicate @recval and put them in not quite legal places, so i prefer
* not to give an error and ignore everything *)
(* cannot instantiate on a recval, but it has possibly been generalized *)
assert (QmlAnnotMap.find_tsc_inst_opt_label label annotmap = None);
let annotmap = QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr e) (QmlAnnotMap.find_tsc_opt_label label annotmap) annotmap in
self annotmap e
| Q.Directive (_, `recval, _, _) ->
assert false
| _ -> tra annotmap e
)
) annotmap code in
gamma, annotmap, code