Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 424 lines (390 sloc) 18.584 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 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
10 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
11 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
12 more details.
13
14 You should have received a copy of the GNU Affero General Public License
15 along with OPA. If not, see <http://www.gnu.org/licenses/>.
16 *)
17 module Q = QmlAst
18 module List = BaseList
19 module Format = BaseFormat
20
21 module IdentAssoc = List.MakeAssoc(Ident)
22
23 exception InvalidRecursion
24
f30a1b1 @BourgerieQuentin [fix] recval: Added warning set for recursive values compilation + un…
BourgerieQuentin authored
25 module Warning = struct
26
27 let recval =
28 let doc = "Recursive values" in
29 WarningClass.create ~name:"recval" ~doc ~err:true ~enable:true ()
30
31 let recval_lambda =
32 let doc = "Recursive value as a lambda - deprecated in js-like syntax (S4)" in
33 WarningClass.create ~parent:recval ~name:"lambda" ~doc ~err:true ~enable:true ()
34
35 let set = WarningClass.Set.create_from_list [
36 recval;
37 recval_lambda;
38 ]
39 end
40
41 let warning_set = Warning.set
42
fccc685 Initial open-source release
MLstate authored
43 let map_intersection merge_value map1 map2 =
44 IdentMap.fold
45 (fun k v1 acc ->
46 try let v2 = IdentMap.find k map2 in
47 IdentMap.add k (merge_value v1 v2) acc
48 with Not_found ->
49 acc
50 ) map1 IdentMap.empty
51
52 (* this function takes a binding (from a recursive set of bindings)
53 * and distinguishes 3 cases:
54 * - the expression is tagged with @recval (coming from rec val or and val in the syntax)
55 * returns Some of a map from the direct dependencies of this expression on the other
56 * identifiers of the bindings of their positions
57 * - the expression is a lambda -> return None
58 * - in other cases, the recursion is invalid, and the InvalidRecursion is raised
59 *)
60 let is_a_val_binding idents (_i, e) =
61 let merge_value = (@) in
62 let find_deps e =
63 QmlAstWalk.Expr.self_traverse_fold
64 (fun self tra deps e ->
65 match e with
66 | Q.Ident (label, i) when IdentSet.mem i idents -> IdentMap.add i [Annot.pos label] deps
67 | Q.Match (_, e, pel) -> (
68 let deps = self deps e in
69 let depss = List.map (fun (_p,e) -> self IdentMap.empty e) pel in
70 match depss with
71 | [] -> assert false
72 | h :: t ->
73 (* we can sure that we depend on an identifier only if all the
74 * branches depend on that identifier
75 * hence we must take the intersection of the dependencies of the branches
76 * and NOT their union *)
77 let intersection = List.fold_left (map_intersection merge_value) h t in
78 IdentMap.merge merge_value intersection deps
79 )
80 | Q.Lambda _ ->
81 deps
82 | _ ->
83 tra deps e
84 ) IdentMap.empty e in
85 let rec is_a_val = function
86 | Q.Lambda _ -> None
87 | Q.Directive (_, `recval, [e], _) ->
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new q…
BourgerieQuentin authored
88 (* TODO *)
fccc685 Initial open-source release
MLstate authored
89 (* checking that you don't put a val rec on a function *)
90 (try match is_a_val e with
91 | None ->
92 let context = QmlError.Context.expr e in
f30a1b1 @BourgerieQuentin [fix] recval: Added warning set for recursive values compilation + un…
BourgerieQuentin authored
93 QmlError.warning ~wclass:Warning.recval_lambda context
94 "This expression is a function, it can be recursive without being tagged with 'val'.";
95 Some (find_deps e)
96 | Some _ -> Some (find_deps e)
97 with InvalidRecursion -> Some (find_deps e));
fccc685 Initial open-source release
MLstate authored
98 | Q.Directive (_, `recval, _, _) -> assert false
99 | Q.Coerce (_, e, _)
100 (* BEWARE before editing: keep this set of directive in sync with the one
101 * in remove_toplevel_directives *)
f6cb10d @BourgerieQuentin [fix] compiler, passes: Check recursive values should traverse all bi…
BourgerieQuentin authored
102 | Q.Directive (_, (#Q.type_directive | #Q.binding_directive), [e], _) -> is_a_val e
fccc685 Initial open-source release
MLstate authored
103 | _ -> raise InvalidRecursion in
104 is_a_val e
105
106 let lazy_type gamma var =
107 let typeident = Q.TypeIdent.of_string Opacapi.Types.finite_single_thread_lazy in
108 let (typeident, _) = QmlTypes.Env.TypeIdent.findi ~visibility_applies:true typeident gamma in
109 (* grabbing the typeident from the gamma, or else we might have the infamous
110 * assert failure somewhere in the typer saying "call type_of_type" *)
111 Q.TypeName ([var], typeident)
112 let lazy_force_type gamma var =
113 Q.TypeArrow ([lazy_type gamma var], var)
114 let mutable_make_type gamma ty =
115 let var = QmlAstCons.Type.next_var () in
116 Q.TypeArrow ([var], lazy_type gamma ty)
117 let mutable_set_type gamma ty =
118 Q.TypeArrow ([lazy_type gamma ty; ty], Q.TypeRecord (Q.TyRow ([], None)))
119
120 let force ~val_ gamma annotmap label lazy_i =
121 let lazy_force = val_ Opacapi.FiniteSingleThreadLazy.force in
122 let ty = QmlAnnotMap.find_ty_label label annotmap in
123 let annotmap, force = QmlAstCons.TypedExpr.ident annotmap lazy_force (lazy_force_type gamma ty) in
124 let annotmap, lazy_i_expr = QmlAstCons.TypedExpr.ident annotmap lazy_i (lazy_type gamma ty) in
125 let annotmap, forced_lazy = QmlAstCons.TypedExpr.apply gamma annotmap force [lazy_i_expr] in
126 annotmap, forced_lazy
127
128 let partition_map p l =
129 let rec aux acc1 acc2 = function
130 | [] -> List.rev acc1, List.rev acc2
131 | h :: t ->
132 match p h with
133 | None -> aux acc1 (h :: acc2) t
134 | Some v -> aux ((h, v) :: acc1) acc2 t in
135 aux [] [] l
136
137 let rec drop_until p = function
138 | [] -> None, []
139 | h :: t ->
140 if p h then
141 Some h, t
142 else
143 drop_until p t
144
145 (* simple check to reject at compile time some cases of illegal value recursion
146 * such as [val rec x = x] *)
147 let check_lack_of_cycle val_deps_bindings =
148 let val_deps = List.map (fun ((i,_e),deps) -> (i,deps)) val_deps_bindings in
149 let pos_of_def i =
150 let (_, e), _ = List.find (fun ((j,_),_) -> Ident.equal i j) val_deps_bindings in
151 Q.Pos.expr e in
152 let rec aux occur i posl =
153 if IdentAssoc.mem i occur then (
154 (* the dependencies that cause the immediate loop *)
155 let calls = List.rev ((i,posl) :: occur) in
156 (* the relevant part of the dependencies *)
157 let _, calls = drop_until (fun (j,_) -> Ident.equal i j) calls in
158 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@]"
159 FilePos.pp (pos_of_def i)
160 (Ident.original_name i)
161 (Format.pp_list "@\n"
162 (fun f (i,posl) ->
163 (* we have several positions when there are branching,
164 * but perhaps it gives too much information to show all
165 * the positions *)
166 let pos = List.hd posl in
167 Format.fprintf f "@[<v2>%s at %a@]" (Ident.original_name i) FilePos.pp pos
168 )) calls;
169 (* exiting to give only one error message in the recursive group *)
170 raise InvalidRecursion
171 ) else
172 let occur = (i,posl) :: occur in
173 (* only non lambda bindings are in val_deps, so we can get a Not_found here *)
174 let deps = try IdentAssoc.find i val_deps with Not_found -> IdentMap.empty in
175 IdentMap.iter (aux occur) deps in
176 try
177 List.iter
178 (fun (i,_) -> aux [] i [])
179 val_deps
180 with InvalidRecursion -> ()
181
182 let move_ei_tsc_gen label annotmap e =
183 let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
184 assert (QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr e) annotmap = None);
185 QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr e) tsc_gen_opt annotmap
186
187 (* now the typing directive are just freaking annoying, because there may be
188 * more slicer directives under them so let's remove them *)
189 let remove_toplevel_directives annotmap e =
190 let rec aux dirs annotmap = function
191 | Q.Coerce (label, e, _)
192 | Q.Directive (label, #Q.type_directive, [e], _) ->
193 let annotmap = move_ei_tsc_gen label annotmap e in
194 aux dirs annotmap e
f6cb10d @BourgerieQuentin [fix] compiler, passes: Check recursive values should traverse all bi…
BourgerieQuentin authored
195 | Q.Directive (label, (#Q.binding_directive as v), [e], []) ->
fccc685 Initial open-source release
MLstate authored
196 let annotmap = move_ei_tsc_gen label annotmap e in
197 aux (v :: dirs) annotmap e
198 | Q.Directive (_, #Q.slicer_directive, _, _) -> assert false
199 | e -> annotmap, dirs, e in
200 aux [] annotmap e
201
202 let rec put_back_toplevel_directives annotmap dirs e =
203 match dirs with
204 | [] -> annotmap, e
205 | dir :: dirs ->
206 let label = Q.Label.expr e in
207 let new_label = Annot.refresh label in
208 let ty = QmlAnnotMap.find_ty_label label annotmap in
209 let tsc_gen_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
210 let annotmap = QmlAnnotMap.remove_tsc_label label annotmap in
211 let annotmap = QmlAnnotMap.add_ty_label new_label ty annotmap in
212 let annotmap = QmlAnnotMap.add_tsc_opt_label new_label tsc_gen_opt annotmap in
213 let e = Q.Directive (new_label, dir, [e], []) in
214 put_back_toplevel_directives annotmap dirs e
215
216 (*
217 * rewrites [rec val x = e1
218 * and f() = e2]
219 * into
220 * [lazy_x = mutable_make(0)
221 * rec f() = e2[lazy_force(lazy_x) / x ]
222 * _ = mutable_set(lazy_x, ( -> e1[lazy_force(lazy_x) / x ]))
223 * x = lazy_force(lazy_x)
224 * ]
225 * The only expressions in the recursive bindings after this rewriting are lambdas
226 * (modulo coercions, some directives, etc.)
227 *)
228 let process_bindings ~val_ gamma annotmap bindings =
229 let idents = List.fold_left (fun acc (i,_) -> IdentSet.add i acc) IdentSet.empty bindings in
230
231 let invalid_bindings = ref [] in
232 let val_deps_bindings, fun_bindings =
233 partition_map
234 (fun b ->
235 try is_a_val_binding idents b
236 with InvalidRecursion ->
237 invalid_bindings := b :: !invalid_bindings;
238 None
239 ) bindings in
240 if !invalid_bindings <> [] then (
241 (match bindings with
242 | [(i,e)] ->
243 (* a more concise error message in the common case of not mutual recursion *)
244 let context = QmlError.Context.expr e in
245 QmlError.serror context "@[<v2> The recursive definition of @{<bright>%s@} is invalid." (Ident.original_name i)
246 | _ ->
247 OManager.serror "@[<v2>In the recursive group consisting of {@[<h>%a@]}, the following recursive definitions are invalid:@\n%a@]@\n@]"
248 (Format.pp_list ",@ " (fun f i -> Format.pp_print_string f (Ident.original_name i))) (IdentSet.elements idents)
249 (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
250 );
251 None
252 ) else (
253 check_lack_of_cycle val_deps_bindings;
254 let val_bindings = List.map fst val_deps_bindings in
255 if val_bindings = [] then
256 None
257 else (
258 let mutable_make = val_ Opacapi.Mutable.make in
259 let mutable_set = val_ Opacapi.Mutable.set in
260
261 (* when we write @server rec val x = ..., then we remove the directive
262 * @server from the body of x and we will put it on all the toplevel
263 * bindings generated from x *)
264 let annotmap, val_bindings =
265 List.fold_left_map
266 (fun annotmap (i,e) ->
267 let annotmap, dirs, e = remove_toplevel_directives annotmap e in
268 annotmap, (i, e, dirs)
269 ) annotmap val_bindings in
270 let lazy_idents = List.map (fun (i,_,_) -> Ident.refreshf ~map:"lazy_%s" i) val_bindings in
271 let annotmap, lazy_defs =
272 List.fold_left_map2
273 (fun annotmap i (_,e,dirs) ->
274 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
275 let annotmap, mutable_make = QmlAstCons.TypedExpr.ident annotmap mutable_make (mutable_make_type gamma ty) in
276 (* could put a well typed value if needed (like {evaluating}) *)
277 let annotmap, zero = QmlAstCons.TypedExpr.int annotmap 7 in
278 let annotmap, def = QmlAstCons.TypedExpr.apply gamma annotmap mutable_make [zero] in
279 let annotmap, def = put_back_toplevel_directives annotmap dirs def in
280 annotmap, (i, def)
281 ) annotmap lazy_idents val_bindings in
282 let annotmap, lazy_sets =
283 List.fold_left_map2
284 (fun annotmap i (_, e, dirs) ->
285 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
286 let annotmap, mutable_set = QmlAstCons.TypedExpr.ident annotmap mutable_set (mutable_set_type gamma ty) in
287 let annotmap, lambda = QmlAstCons.TypedExpr.lambda annotmap [] e in
288 let annotmap, lazy_body = QmlAstCons.TypedExpr.sum_element annotmap ["delayed", lambda] in
289 let annotmap, ref_ = QmlAstCons.TypedExpr.ident annotmap i (lazy_type gamma ty) in
290 let annotmap, set = QmlAstCons.TypedExpr.apply gamma annotmap mutable_set [ref_; lazy_body] in
291 let annotmap, set = put_back_toplevel_directives annotmap dirs set in
292 annotmap, (Ident.next "set_lazy", set)
293 ) annotmap lazy_idents val_bindings in
294 let annotmap, original_bindings =
295 List.fold_left_map2
296 (fun annotmap lazy_i (i, e, dirs) ->
297 let annotmap, forced_lazy = force ~val_ gamma annotmap (Q.Label.expr e) lazy_i in
298 let annotmap, forced_lazy = put_back_toplevel_directives annotmap dirs forced_lazy in
299 annotmap, (i, forced_lazy)
300 ) annotmap lazy_idents val_bindings in
301 let assoc_ident = List.map2 (fun lazy_i (i,_,_) -> (i,lazy_i)) lazy_idents val_bindings in
302 let rewrite_binding annotmap (i,e) =
303 let annotmap, e = QmlAstWalk.Expr.traverse_foldmap
304 (fun tra annotmap e ->
305 match e with
306 | Q.Ident (label, i) -> (
307 try
308 let lazy_i = IdentAssoc.find i assoc_ident in
309 force ~val_ gamma annotmap label lazy_i
310 with Not_found ->
311 annotmap, e
312 )
313 | _ -> tra annotmap e
314 ) annotmap e in
315 annotmap, (i, e) in
316 let rewrite_bindings annotmap l =
317 List.fold_left_map rewrite_binding annotmap l in
318 let annotmap, lazy_sets = rewrite_bindings annotmap lazy_sets in
319 let annotmap, fun_bindings = rewrite_bindings annotmap fun_bindings in
320 Some (
321 annotmap,
322 lazy_defs,
323 (if fun_bindings = [] then None else Some fun_bindings),
324 lazy_sets,
325 original_bindings
326 )
327 )
328 )
329
330 let process_bindings_for_toplevel ~val_ gamma annotmap label bindings =
331 match process_bindings ~val_ gamma annotmap bindings with
332 | None ->
333 None
334 | Some (annotmap, lazy_defs, fun_bindings_opt, lazy_sets, original_bindings) ->
335 let code =
336 Q.NewVal (Annot.refresh label, lazy_sets) ::
337 Q.NewVal (Annot.refresh label, original_bindings) ::
338 [] in
339 let code =
340 match fun_bindings_opt with
341 | None -> code
342 | Some fun_bindings -> Q.NewValRec (Annot.refresh label, fun_bindings) :: code in
343 let code = Q.NewVal (Annot.refresh label, lazy_defs) :: code in
344 let add_to_gamma gamma bindings =
345 List.fold_left
346 (fun gamma (i,e) ->
347 let tsc = QmlTypes.Scheme.quantify (QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap) in
348 QmlTypes.Env.Ident.add i tsc gamma
349 ) gamma bindings in
350 let gamma = add_to_gamma gamma lazy_defs in
351 let gamma = add_to_gamma gamma lazy_sets in
352 Some (gamma, annotmap, code)
353
354 let process_code ~val_ gamma annotmap code =
355
356 (* rewriting newvalrec *)
357 let (gamma, annotmap), code =
358 List.fold_left_collect
359 (fun (gamma, annotmap) c ->
360 match c with
361 | Q.NewValRec (label, bindings) -> (
362 match process_bindings_for_toplevel ~val_ gamma annotmap label bindings with
363 | None -> (gamma, annotmap), [c]
364 | Some (gamma, annotmap, code) -> (gamma, annotmap), code
365 )
366 | _ -> (gamma, annotmap), [c]
367 ) (gamma, annotmap) code in
368
369 (* rewriting letrec and removing @recval *)
370 let annotmap, code =
371 QmlAstWalk.CodeExpr.fold_map
372 (QmlAstWalk.Expr.self_traverse_foldmap
373 (fun self tra annotmap e ->
374 match e with
375
376 | Q.LetRecIn (label, bindings, e_in) -> (
377 match process_bindings ~val_ gamma annotmap bindings with
378 | None -> tra annotmap e
379 | Some (annotmap, lazy_defs, fun_bindings_opt, lazy_sets, original_bindings) ->
380 let label2 = Annot.refresh label in
381 let label4 = Annot.refresh label in
382 let label5 = Annot.refresh label in
383 (* not copying the information for ei *)
384 let ty = QmlAnnotMap.find_ty_label label annotmap in
385 let annotmap = QmlAnnotMap.add_ty_label label2 ty annotmap in
386 let annotmap = QmlAnnotMap.add_ty_label label4 ty annotmap in
387 let annotmap = QmlAnnotMap.add_ty_label label5 ty annotmap in
388 let e_in =
389 Q.LetIn (label2, lazy_sets,
390 Q.LetIn (label, original_bindings, e_in)) in
391 let e_in =
392 match fun_bindings_opt with
393 | None -> e_in
394 | Some fun_bindings -> Q.LetRecIn (label4, fun_bindings, e_in) in
395 let e_in =
396 Q.LetIn (label5, lazy_defs, e_in) in
397 (* need to go down to rewrite e_in and lazy_sets
398 * (although we could just rewrite them instead of calling ourselves
399 * recursively on the term produced) *)
400 tra annotmap e_in
401 )
402
403 | Q.Directive (label, `recval, [e], []) ->
404 (* it is possible that we have a recval on a let that is not recursive
405 * for instance when we say [rec val x = 1] because the dependency analysis
406 * will transform newvalrec and letrec into newval and letin if possible
407 * also other rewriting (such as the one for let pattern = expr in expr)
408 * may duplicate @recval and put them in not quite legal places, so i prefer
409 * not to give an error and ignore everything *)
410 (* cannot instantiate on a recval, but it has possibly been generalized *)
411 assert (QmlAnnotMap.find_tsc_inst_opt_label label annotmap = None);
412 let annotmap = QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr e) (QmlAnnotMap.find_tsc_opt_label label annotmap) annotmap in
413 self annotmap e
414
415 | Q.Directive (_, `recval, _, _) ->
416 assert false
417
418 | _ -> tra annotmap e
419
420 )
421 ) annotmap code in
422
423 gamma, annotmap, code
Something went wrong with that request. Please try again.