Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 789 lines (695 sloc) 27.603 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: talk about the dependencies
20 MAKE SEPARATE PARTS MORE DISTINCTS, PROVIDE A REAL SIGNATURE
21
22 This module contains functions that regroup recursive values in groups, eg:
23 - in the source code:
24 [f1() = f3()
25 f2() = f1()
26 f3() = f1()]
27 - after parsing:
28 [NewVal [(f1,f3())];
29 NewVal [(f2,f1())];
30 NewVal [(f3,f1())]]
31 - after dependency analysis
32 [NewVal [(f1,f3()); (f3,f1())];
33 NewVal [(f2,f1())]]
34
35 It also contains functions that rewrite modules:
36 - in the source code:
37 [{{ x() = y(); y() = x() }}]
38 - after renaming:
39 [{ x = @local(x', {} -> y'({}));
40 y = @local(y', {} -> x'({})) }]
41 - after rewrite:
42 [ rec x' = {} -> y'({})
43 and y' = {} -> x'({})
44 { x = x'; y = y'} ]
45 If your module contains submodules, then their fields will go out too:
46 - source code:
47 [{{ x = {{ x2 = 1 }} }}]
48 - after rewrite:
49 [ x2' = 1;
50 x' = { x2 = x2' }
51 { x = x' } ]
52 This is useless here, but useful when you have recursive modules that
53 call each other's submodules
54 *)
55
56 #<Debugvar:REORDER>
57
58 (* depends *)
59 module List = Base.List
60
61 (* refactoring in progress *)
62
63 (* alias *)
64 module TypeIdent = QmlAst.TypeIdent
65 module TypeIdentMap = QmlAst.TypeIdentMap
66
67 (* shorthands *)
68 module Q = QmlAst
69 module Db = QmlAst.Db
70
71 let ( |> ) x f = f x
72 let ( @> ) f g x = x |> f |> g
73
74
75 (* debug *)
76 let pp_code_elt f (code_elt_node,i) =
77 Format.fprintf f "%d->%a\n"
78 i
79 QmlPrint.pp#code_elt code_elt_node
80
81
82 let pp_code f l =
83 List.iter (pp_code_elt f) l;
84 Format.pp_print_flush f ()
85 let pp_set f s =
86 IntSet.iter (fun i -> Format.fprintf f "%d " i) s;
87 Format.fprintf f "@\n%!"
88
89
90 (*
91 (* For incremental, to detect quickly if a value has changed *)
92 type hash = unit
93 *)
94
95 (* for now just use fields by fields
96 latter group (multi-pattern) of group (record pattern) of fields *)
97
98 (* [ match l with
99 | {nil} ->
100 | {hd tl} -> ... ]
101 gives [[[nil],[hd,tl]], i guess *)
102
103 type fields_group = string list list
104 type fields = fields_group
105 module FieldsOrd = struct type t = fields let compare = compare end
106 module FieldsMap = BaseMap.Make(FieldsOrd)
107
108 (**
109 In [/a/b/c], db_root would be [a]
110 *)
111 type db_root = string
112
113 type 'a gen_dep_context =
114 { vals : (Ident.t * QmlAst.ty option) list
115 ; types : QmlAst.TypeIdent.t list
116 ; fields_groups : fields_group list
117 ; db_roots : db_root list
118 ; database : bool
119 ; other: 'a }
120
121 let empty_gen_dep_context other =
122 { vals = []
123 ; types = []
124 ; fields_groups = []
125 ; db_roots = []
126 ; database = false
127 ; other = other }
128
129 (* FIXME: real merge? *)
130 let merge_vals l1 l2 = l1 @ l2
131 let merge_types l1 l2 = l1 @ l2
132 let merge_fields_groups l1 l2 = l1 @ l2
133 let merge_db_roots l1 l2 = l1 @ l2
134 let merge_database b1 b2 = b1 || b2
135
136 let merge_context merge_other context1 context2 =
137 { vals = merge_vals context1.vals context2.vals
138 ; types = merge_types context1.types context2.types
139 ; fields_groups = merge_fields_groups context1.fields_groups context2.fields_groups
140 ; db_roots = merge_db_roots context1.db_roots context2.db_roots
141 ; database = merge_database context1.database context2.database
142 ; other = merge_other context1.other context2.other }
143 let merge_contexts merge_other empty_context contexts =
144 List.fold_left (merge_context merge_other) empty_context contexts
145
146 (* FIXME: collision, or duplicates? *)
147 (* should be consistent with merge *)
148 let add_root s context = {context with db_roots = s :: context.db_roots}
149 let add_group g context = {context with fields_groups = g :: context.fields_groups}
150 let add_type t context = {context with types = t :: context.types}
151 let add_types ts context = {context with types = ts @ context.types}
152 let add_val v context = {context with vals = (v,None) :: context.vals}
153 let add_vals vs context = {context with vals = List.map (fun v -> v,None) vs @ context.vals}
154 let add_database context = {context with database = true}
155
156 (* will contain what is used by a declaration,
157 a declaration may contain many values *)
158 type directive_dep = [ `hybrid_value | `insert_server_value of Ident.t | `fun_action of QmlAst.fun_action_content option ]
159
160 (* That function fold dependencies for a given directive *)
161 let fold_directive_deps get_id_ident get_id_str (directive:directive_dep) fold acc =
162 let ifold lst =
163 List.fold_left
164 (fun acc str_dep -> try fold (get_id_str str_dep) acc with Not_found -> acc)
165 acc lst
166 in match directive with
167 | `hybrid_value ->
168 ifold [Opacapi.OpaSerialize.unserialize_unsafe]
169 | `insert_server_value i ->
170 (try fold (get_id_ident i) acc with Not_found -> acc)
171 | `fun_action _ ->
172 ifold [Opacapi.FunActionServer.serialize_argument]
173
174 type dep = directive_dep list
175 type dep_context = dep gen_dep_context
176 let empty_dep_context = empty_gen_dep_context []
177 let merge_dep_other = (@)
178 let merge_dep_context = merge_context merge_dep_other
179 let merge_dep_contexts = merge_contexts merge_dep_other empty_dep_context
180
181 let db_root_of_path l =
182 match l with
183 | (QmlAst.Db.Decl_fld s) :: _ -> s
184 | _ -> assert false
185
186 (* todo factoriser avec Reordering.types_deps *)
187 let get_typenames ty = QmlAstWalk.Type.fold (
188 fun acc ty ->
189 match ty with
190 | Q.TypeName(_,tyn)-> tyn::acc
191 |_ -> acc
192 ) [] ty
193
194 let get_fields_ty ty = QmlAstWalk.Type.fold (
195 fun acc ty ->
196 match ty with
197 | Q.TypeRecord (Q.TyRow (lf,_))-> [List.map fst lf]@acc
198 | Q.TypeSum (Q.TyCol (llf,_))-> (List.map (List.map fst ) llf)@acc
199 |_ -> acc
200 ) [] ty
201
202 let get_fields_pat pat = QmlAstWalk.Pattern.fold_down (
203 fun acc pat->
204 match pat with
205 | Q.PatRecord (_, fields, _) -> List.rev_map_append fst fields acc
206 | _ -> acc
207 ) [] pat
208
209 let get_type_dep_context ty = {
210 empty_dep_context with
211 types = get_typenames ty ;
212 fields_groups = [get_fields_ty ty]
213 }
214
215
216 let type_deps =
217 QmlAstWalk.Type.fold
218 (fun acc -> function
219 | QmlAst.TypeName (_, ident) -> ident :: acc
220 | _ -> acc) []
221
222 let type_deps =
223 QmlAstWalk.Type.fold
224 (fun acc -> function
225 | QmlAst.TypeName (_, ident) -> ident :: acc
226 | _ -> acc) []
227
228 (* somewhat of a hack to avoid having to carry around an environment *)
229 let remote_call_key i =
230 "__call__" ^ Ident.stident i
231 let remote_call_ident i =
232 Ident.source (remote_call_key i)
233
234 (**
235 [get_expr_dep_context] gives the toplevel direct dependencies of an
236 expression
237 The environment contains the identifiers in scope (both types and values)
238 but not the toplevel ones
239 *)
240 let get_expr_dep_context ?filter e =
241 QmlAstWalk.Expr.fold_with_exprmap
242 (fun env acc e ->
243 match e with
244 (* nothing special for bindings except that the environment
245 * grows but this is already taken care of the fold_with_env
246 * function *)
247 | Q.LetIn _
248 | Q.Apply _
249 | Q.Const _
250 | Q.Bypass _
251 | Q.Lambda _
252 | Q.LetRecIn _ -> acc
253 | Q.Coerce (_, _, ty) ->
254 let deps_ty = type_deps ty in
255 {acc with types = deps_ty @ acc.types }
256 | Q.Match (_, _e, _pel) -> acc
257 (*{ acc with fields_groups = List.fold (fun groups (p,_)-> add_group (get_fields_pat p) groups) acc.fields_groups _pel }*)
258 (*let _p = List.map pel in*)
259 (* FIXME: ??? don't know what to do *)
260 | Q.Path (_, dbelt, _)-> (
261 let acc = Option.if_none filter (add_database acc) acc in
262 (* taking the first elt of the path *)
263 match List.hd dbelt with
264 | Q.FldKey s -> Option.if_none filter (add_root s acc) acc
265 | Q.NewKey
266 | Q.ExprKey _ ->
267 (* not possible, see the parser *)
268 assert false
269 )
270 | Q.Record (_, l) ->
271 Option.if_none filter (add_group [List.map fst l] acc) acc
272
273 | Q.Dot (_, _, f)
274 | Q.ExtendRecord (_, f,_, _) ->
275 Option.if_none filter (add_group [[f]] acc) acc
276
277 | Q.Ident (_, i) ->
278 if not (IdentMap.mem i env) then
279 match filter with
280 | None -> add_val i acc
281 | Some f when f i -> add_val i acc
282 | _ -> acc
283 else
284 acc
285 | Q.Directive (_, (`comet_call | `ajax_call _), el, tyl) -> (
286 assert (tyl = []);
287 match el with
288 | [ Q.Ident (_, i) ] ->
289 (* when doing a remote call, we depend on the stub, not only on the implementation *)
290 {acc with vals = (remote_call_ident i, None) :: acc.vals}
291 | _ -> assert false
292 )
293 | Q.Directive (_, dir, exprs, tys) ->
294 let acc =
295 match dir with
296 | #directive_dep as dir ->
297 { acc with other = dir::acc.other }
298 | _ -> acc
299 in
300 let acc =
301 let fold_ty acc ty =
302 merge_dep_context
303 {empty_dep_context with types = get_typenames ty}
304 acc
305 in
306 (* FIXME: check what should be done wrt filter and this case,
307 surfaceDependencies and qmlDependencies desagree *)
308 match filter with
309 | None ->
310 (* we should fold on arguments + on the type of the directive *)
311 let acc = List.fold_left fold_ty acc tys in
312 let acc = fold_ty acc (QmlDirectives.ty dir exprs tys) in
313 acc
314
315 | Some _ -> acc
316 in
317 acc
318
319 ) empty_dep_context e
320
321
322 (**
323 [get_local_expr_dep_context] is used when you don't want all the
324 dependencies of an expression but only dependencies on the identifiers
325 present in the set [names]
326 it allows you to reorder/split a set of mutually recursive bindings
327 *)
328 let get_local_expr_dep_context names expr =
329 let filter i = IdentSet.mem i names in
330 get_expr_dep_context ~filter expr
331
332 (**
333 [get_code_elt_dep_context] gives you the toplevel dependencies of a code_elt
334 *)
335 let get_code_elt_dep_context code_elt_node =
336 match code_elt_node with
337 | Q.Database _ -> empty_dep_context
338 | Q.NewDbValue (_, Db.Db_TypeDecl([_] ,ty)) ->
339 { empty_dep_context with types = get_typenames ty}
340 | Q.NewDbValue (_, Db.Db_TypeDecl(p,ty)) ->
341 { empty_dep_context with
342 db_roots = [db_root_of_path p] ;
343 types = get_typenames ty
344 }
345 | Q.NewDbValue (_, ( Db.Db_Default (p, _)
346 | Db.Db_Constraint (p, _)
347 | Db.Db_Alias (_, p)
348 | Db.Db_Virtual (p, _) as db_def) ) ->
349 fst(Db.foldmap_expr
350 (fun dep_context e -> merge_dep_context (get_expr_dep_context e) dep_context, e)
351 {empty_dep_context with db_roots = [db_root_of_path p]}
352 db_def)
353
354 | Q.NewType (_, tyl) ->
355 (* FIXME: should i remove i from the dependencies?
356 * probably not: the element will be dependent on itself, but
357 * it seems normal since it is indeed recursive
358 *)
359 let contexts =
360 List.map
361 (fun ty_def -> get_type_dep_context ty_def.Q.ty_def_body) tyl in
362 merge_dep_contexts contexts
363 | Q.NewVal (_, pel)
364 | Q.NewValRec (_, pel) ->
365 (* FIXME: should i remove the pat vars from the dependencies? *)
366 let contexts = List.map (snd @> get_expr_dep_context) pel in
367 merge_dep_contexts contexts
368
369 (* contains what a declaration has to offer *)
370 type api = unit
371 type api_context = api gen_dep_context
372 let empty_api_context = empty_gen_dep_context ()
373 let merge_api_other _ _ = ()
374 let merge_api_context = merge_context merge_api_other
375 let merge_api_contexts = merge_contexts merge_api_other empty_api_context
376
377 (**
378 [get_code_elt_api_context] gives you what is provided by a code_elt
379 *)
380 let get_expr_api_context = function
381 | Q.Directive (_, (`ajax_publish _|`comet_publish), el, _) -> (
382 match el with
383 | [ Q.Ident (_, i) ] -> [(remote_call_ident i, None)]
384 | _ -> assert false
385 )
386 | _ -> []
387
388 let get_code_elt_api_context code_elt_node =
389 match code_elt_node with
390 | Q.Database _ ->
391 empty_api_context
392 | Q.NewDbValue (_, Db.Db_TypeDecl(p,_)) ->
393 (* all the [db /map/...] define the root '/map'
394 * or else in [ db /map/a : string
395 * db /map/b : string ], '/map' is never defined
396 *)
397 {empty_api_context with db_roots = [db_root_of_path p]; database = true}
398 | Q.NewDbValue _ ->
399 {empty_api_context with database = true}
400 | Q.NewType (_, tyl) ->
401 { empty_api_context with
402 types =
403 List.map (fun ty_def -> ty_def.QmlAst.ty_def_name) tyl (*; fields_groups = [get_fields_ty ty] *) }
404 | Q.NewVal (_, iel)
405 | Q.NewValRec (_, iel) ->
406 {empty_api_context with vals = List.concat_map (fun (i,e) -> get_expr_api_context e @ [(i,None)]) iel}
407
408
409 (**
410 These maps map identifiers to an int that identifies the declaration
411 that defines them
412 the int is chosen to be the number in the annot of the code_elt
413
414 Used to compute deps from api_context
415 *)
416 type context_linker_cache =
417 { c_identifiers : int IdentMap.t
418 ; c_type_identifiers : int QmlAst.TypeIdentMap.t
419 ; c_db_roots : int list StringMap.t
420 ; c_fields : int FieldsMap.t
421 ; c_database : int list }
422
423 let empty_context_linker_cache : context_linker_cache =
424 { c_identifiers = IdentMap.empty
425 ; c_type_identifiers = TypeIdentMap.empty
426 ; c_db_roots = StringMap.empty
427 ; c_fields = FieldsMap.empty
428 ; c_database = [] }
429
430 let get_context_linker_cache_input lcode =
431 List.map (fun (code_elt,i) -> i, get_code_elt_api_context code_elt) lcode
432
433 let get_get_deps_input lcode =
434 List.map (fun (code_elt,i) ->
435 let foo = get_code_elt_dep_context code_elt in
436 (* let () = (print_string @* string_of_int) i in
437 let () = print_string " depends of " in
438 let () = List.iter (print_string @* ((^) " ") @* ExprIdent.to_string @* fst) foo.vals in
439 let () = print_string "\n" in
440 *)
441 code_elt, i, foo
442 ) lcode
443
444
445
446 (* ************************************************************************** *)
447 (** {b Visibility} : Not exported outside this module. *)
448 (* ************************************************************************** *)
449 let identMap_safe_add ident i idents =
450 try IdentMap.safe_add ident i idents with
451 | Invalid_argument "Base.Map.safe_add" ->
452 Printf.printf "Cannot find %s\n%!" (Ident.to_string ident);
453 (* Without any mean to create an expressive context for an erroe message,
454 the best we can do is to assert, at least in case of raising we will
455 at least have a line number in the source. *)
456 assert false
457
458
459
460 (* ************************************************************************** *)
461 (** {b Visibility} : Not exported outside this module. *)
462 (* ************************************************************************** *)
463 let typeIdentMap_safe_add ident i idents =
464 try TypeIdentMap.safe_add ident i idents with
465 | Invalid_argument "Base.Map.safe_add" ->
466 (* Without any mean to create an expressive context for an erroe message,
467 the best we can do is to assert, at least in case of raising we will
468 at least have a line number in the source. *)
469 assert false
470
471 let stringMap_safe_add ident i idents = StringMap.add ident i idents
472
473
474
475 (* ************************************************************************** *)
476 (** {b Visibility} : Not exported outside this module. *)
477 (* ************************************************************************** *)
478 let fieldsMap_safe_add ident i idents =
479 try FieldsMap.safe_add ident i idents with
480 | Invalid_argument "Base.Map.safe_add" ->
481 (* Without any mean to create an expressive context for an erroe message,
482 the best we can do is to assert, at least in case of raising we will
483 at least have a line number in the source. *)
484 assert false
485
486
487 let context_linker_cache iapis =
488 List.fold_left
489 (fun { c_identifiers = idents
490 ; c_type_identifiers =types
491 ; c_db_roots = db_roots
492 ; c_fields = fields
493 ; c_database = database} ((i:int),api) ->
494 { c_identifiers =
495 List.fold_left (fun idents (ident,_) -> identMap_safe_add ident i idents) idents api.vals
496 ; c_type_identifiers =
497 List.fold_left (fun types ident -> typeIdentMap_safe_add ident i types) types api.types
498 ; c_db_roots =
499 List.fold_left (fun db_roots db_root ->
500 let prev = Option.default [] (StringMap.find_opt db_root db_roots) in
501 StringMap.add db_root (i :: prev) db_roots
502 ) db_roots api.db_roots
503 ; c_fields =
504 List.fold_left (fun fields g -> fieldsMap_safe_add g i fields) fields api.fields_groups
505 ; c_database = if api.database then i :: database else database }
506 ) empty_context_linker_cache iapis
507
508
509
510 (** @raise Not_found. *)
511 let identmap_find i m =
512 match IdentMap.find_opt i m with
513 | None ->
514 (* if an exception is raised here, it means that someone depends on an
515 * identifier but nobody defines it
516 * it can happen in the following (legal) cases:
517 * - we are reordering the client code and it contains server identifiers
518 * - some identifiers are used but not yet defined
519 * (like the one used to share the runtime structure of types _v*_memo_ty)
520 * And of course, it happens when you really have an unbound identifier
521 *)
522 (*Printf.printf "Dependencies.identmap_find: %s\n%!" (Ident.to_string i);*)
523 raise Not_found
524 | Some v -> v
525
526
527
528 (** @raise Not_found. *)
529 let typemap_find i m =
530 match TypeIdentMap.find_opt i m with
531 | None ->
532 (*Printf.printf "Dependencies.typemap_find: %s\n%!" (TypeIdent.to_string i);*)
533 raise Not_found
534 | Some v -> v
535
536
537 let get_deps val_ { c_identifiers = vals
538 ; c_type_identifiers = types
539 ; c_db_roots = db_roots
540 ; c_fields = fields
541 ; c_database = database } ideps =
542 let fold_directive_deps =
543 fold_directive_deps
544 (fun ident -> identmap_find ident vals)
545 (fun str -> identmap_find (val_ str) vals) in
546 List.map
547 (fun (_,i,dep_context) ->
548 let set = IntSet.empty in
549 let set =
550 List.fold_left
551 (fun set (ident, _tyo) ->
552 try IntSet.add (identmap_find ident vals) set with
553 Not_found -> set)
554 set dep_context.vals in
555 let set =
556 List.fold_left
557 (fun set type_ ->
558 try IntSet.add (typemap_find type_ types) set with
559 Not_found -> set)
560 set dep_context.types in
561 let set =
562 List.fold_left
563 (fun set db_root ->
564 try IntSet.add_list (StringMap.find db_root db_roots) set
565 with Not_found -> set)
566 set dep_context.db_roots in
567 let set =
568 if dep_context.database then
569 IntSet.add_list database set
570 else
571 set in
572 let set =
573 List.fold_left
574 (fun set field ->
575 try IntSet.add (FieldsMap.find field fields) set with
576 Not_found -> set)
577 set dep_context.fields_groups in
578 let set =
579 List.fold_left
580 (fun set directive ->
581 fold_directive_deps directive IntSet.add set)
582 set dep_context.other in
583 (i, set)
584 ) ideps
585
586 (**
587 create the map that map the number of a declaration to the declaration
588 itself
589 *)
590 let map_back lcode =
591 List.fold_left
592 (fun map (code_elt,i) ->
593 IntMap.add i code_elt map
594 ) IntMap.empty lcode
595
596 (**
597 When given a list of code_elt, gives back the list where all newval
598 are regrouped into one newval and put it last in the list
599 *)
600 let special_flatten (isRec:int -> bool) (of_int:int->'a) l =
601 let isVal = function Q.NewValRec _ | Q.NewVal _ -> true | _ -> false in
602 let getVal = function Q.NewValRec (_, l) | Q.NewVal (_, l) -> l | _ -> assert false in
603 let label = Annot.nolabel "QmlDependencies.special_flatten" in
604 let newval rec_ l =
605 if rec_ then Q.NewValRec (label, l) else Q.NewVal (label, l) in
606 match l with
607 | [i] -> let c = of_int i in
608 if isVal c then [newval (isRec i) (getVal c)]
609 else [c]
610 | _ ->
611 let l = List.rev (List.map of_int l) in
612 let vals,others = List.partition isVal l in
613 (* this match ensures that we do not construct NewValRec []
614 * which breaks assertions in the backend *)
615 match vals with
616 | [] -> others
617 | _ -> others @ [ Q.NewValRec (label, (List.map getVal vals |> List.flatten)) ]
618
619 let flatten code =
620 let flatten x = match x with
621 | Q.NewVal (label, pel)
622 | Q.NewValRec (label, pel) -> List.map (fun x -> Q.NewVal (label, [x])) pel
623 | _ -> [x]
624 in
625 List.concat_map flatten code
626
627 let debug _f _x =
628 #<If>
629 (Format.printf "------@\n%a%!" _f _x)
630 #<End>
631
632 (**
633 This function reorders the toplevel
634
635 Take the function that computes the transivite closure of the dependency
636 relation as an argument because doing otherwise would (for now) create
637 circular dependencies between libraries
638
639 *)
640 let reorder_toplevel val_ roots roots_addon create_groups lcode =
641 let lcode = flatten lcode in
642 (* FIXME: should i remove the pat vars from the dependencies? *)
643 let lcode = List.mapi (fun i c -> (c,i)) lcode in
644 debug pp_code lcode;
645 let iapis = get_context_linker_cache_input lcode in
646 let ideps = get_get_deps_input lcode in
647 let {c_identifiers=vals;c_type_identifiers=types} as context_linker_cache = context_linker_cache iapis in
648 let deps = get_deps val_ context_linker_cache ideps in
649
650 debug (fun f l -> List.iter (fun (i,s) -> Format.fprintf f "%d -> %a" i pp_set s) l) deps;
651 let roots =
652 if roots = [] then [] else
653 List.rev_append
654 (
655 List.rev_append
656 (
657 (* if we have roots that are not defined, we simply ignore them *)
658 List.filter_map (fun i -> IdentMap.find_opt i vals) roots
659 )
660 ( TypeIdentMap.fold (fun _ v acc -> v::acc) types [] ) (*todo virer ca quand on aura vire libconvert *)
661 )
662 (
663 List.fold_left
664 (fun acc (code, i) ->
665 match code with
666 | Q.Database _ -> i::acc
667 | Q.NewDbValue _ -> i::acc
668 | _ -> acc
669 )
670 []
671 lcode
672 )
673 in
674 let roots_addon =
675 IdentMap.fold
676 (fun ident list acc ->
677 Option.default_map
678 acc
679 (fun val' ->
680 IntMap.add val'
681 (List.filter_map (fun i -> IdentMap.find_opt i vals) list) acc)
682 (IdentMap.find_opt ident vals)
683 )
684 roots_addon
685 IntMap.empty
686 in
687 let ((groups : (int * bool * IntSet.t) list),_) = create_groups roots roots_addon deps in
688 debug (fun f l -> List.iter (fun (i,isrec,s) -> Format.fprintf f "%d(%B) -> %a" i isrec pp_set s) l) groups;
689 let map_back = map_back lcode in
690 let declss = List.map (fun (_, _, group) -> IntSet.fold (fun i acc -> i::acc) group []) groups
691 (* this should be equivalent to: List.map (fun (_, group) -> IntSet.elements group) groups
692 but somehow, it is not ! maybe the rest depends on the order ? *)
693 in
694 let isRec =
695 let deps = IntMap.from_list deps in
696 fun i -> IntSet.mem i (IntMap.find i deps)
697 in
698 let of_int i = IntMap.find i map_back in
699 let lcode = List.concat_map (special_flatten isRec of_int) declss in
700 (*debug pp_code lcode;*)
701 lcode
702
703 let safe_union s1 s2 =
704 let s = IdentSet.union s1 s2 in
705 assert (IdentSet.cardinal s1 + IdentSet.cardinal s2 = IdentSet.cardinal s);
706 s
707
708 let get_all_deps get_var_set bindings =
709 let names, exprs = List.split bindings in
710 let possible_deps =
711 names
712 |> List.map get_var_set
713 |> List.fold_left safe_union IdentSet.empty in
714 List.map (get_local_expr_dep_context possible_deps) exprs
715
716 let regroup map_expr (_,intset) =
717 assert (IntSet.cardinal intset <> 0);
718 intset
719 |> IntSet.elements
720 |> List.map (fun i -> IntMap.find i map_expr)
721
722 (**
723 reorder a list of bindings the same way reorder_toplevel does
724 the bindings have the type ('a * expr) list, where 'a will be
725 either ident or pattern
726 use the functions below, that are already specialized for idents
727 and patterns
728 *)
729 let reorder roots roots_addon create_groups lcode =
730 reorder_toplevel roots roots_addon create_groups lcode
731
732
733 (*------------------------------------*)
734 (*------ not separated cleaning -----*)
735 (*------------------------------------*)
736
737 let idents_of_annots unreachable_annots code =
738 List.fold_left
739 (fun acc -> function
740 | Q.NewValRec (_, iel)
741 | Q.NewVal (_, iel) ->
742 List.fold_left
743 (fun acc (i, expr) ->
744 let annot = Q.QAnnot.expr expr in
745 if IntSet.mem (Annot.to_int annot) unreachable_annots then
746 IdentSet.add i acc
747 else
748 acc) acc iel
749 | _ -> assert false) IdentSet.empty code
750
751 let is_root e =
752 QmlAstWalk.Expr.traverse_exists
753 (fun tra -> function
754 | Q.Apply _ -> true
755 | Q.Lambda _ -> false
756 | e -> tra e) e
757 let get_unreachable_idents_of_code val_ roots server_code client_code =
758 let code = server_code @ client_code in
759 let lcode = flatten code in
760 let roots =
761 List.filter_map
762 (function
763 | Q.NewVal (_, [_i, e])
764 | Q.NewValRec (_, [_i, e]) ->
765 if List.exists (fun j -> Ident.equal _i j) roots || is_root e then (
766 (*Printf.printf "%s is a root\n%!" (Ident.to_string _i);*)
767 let annot = Q.QAnnot.expr e in
768 Some (Annot.to_int annot)
769 ) else None
770 | _ -> assert false) lcode in
771 let lcode =
772 List.map (function
773 | Q.NewVal (_, [_, e])
774 | Q.NewValRec (_, [_, e]) as c ->
775 let annot = Q.QAnnot.expr e in
776 (c, Annot.to_int annot)
777 | _ -> assert false) lcode in
778 let iapis = get_context_linker_cache_input lcode in
779 let ideps = get_get_deps_input lcode in
780 let context_linker_cache = context_linker_cache iapis in
781 let deps = get_deps val_ context_linker_cache ideps in
782 let unreachable_annots = GraphUtils.Int.give_unreachable_nodes roots deps in
783 let unreachable_idents = idents_of_annots unreachable_annots code in
784 let filter code =
785 (*Printf.printf "%d unreachable idents\n%!" (IdentSet.size unreachable_idents);*)
786 QmlAstWalk.Code.filter_binding
787 (fun (i,_) -> not (IdentSet.mem i unreachable_idents)) code in
788 unreachable_idents, filter server_code, filter client_code
Something went wrong with that request. Please try again.