Revision 45c13277
src/causality.ml | ||
---|---|---|
470 | 470 |
(map : disjoint_map) |
471 | 471 |
end |
472 | 472 |
|
473 |
(* replace variable [v] by [v'] in disjunction [map]. Then:
|
|
473 |
(* merge variables [v] and [v'] in disjunction [map]. Then:
|
|
474 | 474 |
- the mapping v' becomes v' |-> (map v) inter (map v') |
475 | 475 |
- the mapping v |-> ... then disappears |
476 | 476 |
- other mappings become x |-> (map x) \ (if v in x then v else v') |
477 | 477 |
*) |
478 |
let replace_in_disjoint_map map v v' =
|
|
478 |
let merge_in_disjoint_map map v v' =
|
|
479 | 479 |
begin |
480 | 480 |
Hashtbl.replace map v'.var_id (CISet.inter (Hashtbl.find map v.var_id) (Hashtbl.find map v'.var_id)); |
481 | 481 |
Hashtbl.remove map v.var_id; |
482 | 482 |
Hashtbl.iter (fun x map_x -> Hashtbl.replace map x (CISet.remove (if CISet.mem v map_x then v else v') map_x)) map; |
483 | 483 |
end |
484 | 484 |
|
485 |
(* replace variable [v] by [v'] in disjunction [map]. |
|
486 |
[v'] is a dead variable. Then: |
|
487 |
- the mapping v' becomes v' |-> (map v) |
|
488 |
- the mapping v |-> ... then disappears |
|
489 |
- all mappings become x |-> ((map x) \ { v}) union ({v'} if v in map x) |
|
490 |
*) |
|
491 |
let replace_in_disjoint_map map v v' = |
|
492 |
begin |
|
493 |
Hashtbl.replace map v'.var_id (Hashtbl.find map v.var_id); |
|
494 |
Hashtbl.remove map v.var_id; |
|
495 |
Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (if CISet.mem v mapx then CISet.add v' (CISet.remove v mapx) else CISet.remove v' mapx)) map; |
|
496 |
end |
|
497 |
|
|
498 |
(* remove variable [v] in disjunction [map]. Then: |
|
499 |
- the mapping v |-> ... then disappears |
|
500 |
- all mappings become x |-> (map x) \ { v} |
|
501 |
*) |
|
502 |
let remove_in_disjoint_map map v = |
|
503 |
begin |
|
504 |
Hashtbl.remove map v.var_id; |
|
505 |
Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (CISet.remove v mapx)) map; |
|
506 |
end |
|
507 |
|
|
485 | 508 |
let pp_disjoint_map fmt map = |
486 | 509 |
begin |
487 | 510 |
Format.fprintf fmt "{ /* disjoint map */@."; |
... | ... | |
503 | 526 |
|
504 | 527 |
(* Merges elements of graph [g2] into graph [g1] *) |
505 | 528 |
let merge_with g1 g2 = |
529 |
begin |
|
506 | 530 |
IdentDepGraph.iter_vertex (fun v -> IdentDepGraph.add_vertex g1 v) g2; |
507 | 531 |
IdentDepGraph.iter_edges (fun s t -> IdentDepGraph.add_edge g1 s t) g2 |
532 |
end |
|
533 |
|
|
534 |
let add_external_dependency outputs mems g = |
|
535 |
let caller ="!_world" in |
|
536 |
begin |
|
537 |
IdentDepGraph.add_vertex g caller; |
|
538 |
ISet.iter (fun o -> IdentDepGraph.add_edge g caller o) outputs; |
|
539 |
ISet.iter (fun m -> IdentDepGraph.add_edge g caller m) mems; |
|
540 |
end |
|
508 | 541 |
|
509 | 542 |
let global_dependency node = |
510 | 543 |
let mems = ExprDep.node_memory_variables node in |
511 | 544 |
let inputs = ExprDep.node_input_variables node in |
545 |
let outputs = ExprDep.node_output_variables node in |
|
512 | 546 |
let node_vars = ExprDep.node_variables node in |
513 | 547 |
let (g_non_mems, g_mems) = ExprDep.dependence_graph mems inputs node_vars node in |
514 | 548 |
(*Format.eprintf "g_non_mems: %a" pp_dep_graph g_non_mems; |
... | ... | |
516 | 550 |
CycleDetection.check_cycles g_non_mems; |
517 | 551 |
let (vdecls', eqs', g_mems') = CycleDetection.break_cycles node mems g_mems in |
518 | 552 |
(*Format.eprintf "g_mems': %a" pp_dep_graph g_mems';*) |
519 |
merge_with g_non_mems g_mems'; |
|
520 |
{ node with node_eqs = eqs'; node_locals = vdecls'@node.node_locals }, |
|
521 |
g_non_mems |
|
522 |
|
|
553 |
begin |
|
554 |
merge_with g_non_mems g_mems'; |
|
555 |
add_external_dependency outputs mems g_non_mems; |
|
556 |
{ node with node_eqs = eqs'; node_locals = vdecls'@node.node_locals }, |
|
557 |
g_non_mems |
|
558 |
end |
|
523 | 559 |
|
524 | 560 |
(* Local Variables: *) |
525 | 561 |
(* compile-command:"make -C .." *) |
src/clock_calculus.ml | ||
---|---|---|
430 | 430 |
(Const_int i) -> i |
431 | 431 |
| _ -> failwith "Internal error: int_factor_of_expr" |
432 | 432 |
|
433 |
(* Unifies all the clock variables in the clock type of a tuple |
|
434 |
expression, so that the clock type only uses at most one clock variable *) |
|
435 |
let unify_tuple_clock ref_ck_opt ck = |
|
436 |
let ck_var = ref ref_ck_opt in |
|
437 |
let rec aux ck = |
|
438 |
match (repr ck).cdesc with |
|
439 |
| Con _ |
|
440 |
| Cvar _ -> |
|
441 |
begin |
|
442 |
match !ck_var with |
|
443 |
| None -> |
|
444 |
ck_var:=Some ck |
|
445 |
| Some v -> |
|
446 |
(* may fail *) |
|
447 |
unify v ck |
|
448 |
end |
|
449 |
| Ctuple cl -> |
|
450 |
List.iter aux cl |
|
451 |
| Carrow _ -> assert false (* should not occur *) |
|
452 |
| Ccarrying (_, ck1) -> |
|
453 |
aux ck1 |
|
454 |
| _ -> () |
|
455 |
in |
|
456 |
aux ck |
|
457 |
|
|
458 |
(* Unifies all the clock variables in the clock type of an imported |
|
459 |
node, so that the clock type only uses at most one base clock variable, |
|
460 |
that is, the activation clock of the node *) |
|
461 |
let unify_imported_clock ref_ck_opt ck = |
|
462 |
let ck_var = ref ref_ck_opt in |
|
463 |
let rec aux ck = |
|
464 |
match (repr ck).cdesc with |
|
465 |
| Cvar _ -> |
|
466 |
begin |
|
467 |
match !ck_var with |
|
468 |
| None -> |
|
469 |
ck_var:=Some ck |
|
470 |
| Some v -> |
|
471 |
(* cannot fail *) |
|
472 |
unify v ck |
|
473 |
end |
|
474 |
| Ctuple cl -> |
|
475 |
List.iter aux cl |
|
476 |
| Carrow (ck1,ck2) -> |
|
477 |
aux ck1; aux ck2 |
|
478 |
| Ccarrying (_, ck1) -> |
|
479 |
aux ck1 |
|
480 |
| Con (ck1, _, _) -> aux ck1 |
|
481 |
| _ -> () |
|
482 |
in |
|
483 |
aux ck |
|
484 |
|
|
485 | 433 |
(** [clock_uncarry ck] drops the possible carrier name from clock [ck] *) |
486 | 434 |
let clock_uncarry ck = |
487 | 435 |
let ck = repr ck in |
... | ... | |
544 | 492 |
| Mismatch (cr1,cr2) -> |
545 | 493 |
raise (Error (loc, Carrier_mismatch (cr1,cr2))) |
546 | 494 |
|
495 |
(* Unifies all the clock variables in the clock type of a tuple |
|
496 |
expression, so that the clock type only uses at most one clock variable *) |
|
497 |
let unify_tuple_clock ref_ck_opt ck loc = |
|
498 |
let ck_var = ref ref_ck_opt in |
|
499 |
let rec aux ck = |
|
500 |
match (repr ck).cdesc with |
|
501 |
| Con _ |
|
502 |
| Cvar _ -> |
|
503 |
begin |
|
504 |
match !ck_var with |
|
505 |
| None -> |
|
506 |
ck_var:=Some ck |
|
507 |
| Some v -> |
|
508 |
(* may fail *) |
|
509 |
try_unify v ck loc |
|
510 |
end |
|
511 |
| Ctuple cl -> |
|
512 |
List.iter aux cl |
|
513 |
| Carrow _ -> assert false (* should not occur *) |
|
514 |
| Ccarrying (_, ck1) -> |
|
515 |
aux ck1 |
|
516 |
| _ -> () |
|
517 |
in |
|
518 |
aux ck |
|
519 |
|
|
520 |
(* Unifies all the clock variables in the clock type of an imported |
|
521 |
node, so that the clock type only uses at most one base clock variable, |
|
522 |
that is, the activation clock of the node *) |
|
523 |
let unify_imported_clock ref_ck_opt ck loc = |
|
524 |
let ck_var = ref ref_ck_opt in |
|
525 |
let rec aux ck = |
|
526 |
match (repr ck).cdesc with |
|
527 |
| Cvar _ -> |
|
528 |
begin |
|
529 |
match !ck_var with |
|
530 |
| None -> |
|
531 |
ck_var:=Some ck |
|
532 |
| Some v -> |
|
533 |
(* cannot fail *) |
|
534 |
try_unify v ck loc |
|
535 |
end |
|
536 |
| Ctuple cl -> |
|
537 |
List.iter aux cl |
|
538 |
| Carrow (ck1,ck2) -> |
|
539 |
aux ck1; aux ck2 |
|
540 |
| Ccarrying (_, ck1) -> |
|
541 |
aux ck1 |
|
542 |
| Con (ck1, _, _) -> aux ck1 |
|
543 |
| _ -> () |
|
544 |
in |
|
545 |
aux ck |
|
546 |
|
|
547 | 547 |
(* Clocks a list of arguments of Lustre builtin operators: |
548 | 548 |
- type each expression, remove carriers of clocks as |
549 | 549 |
carriers may only denote variables, not arbitrary expr. |
... | ... | |
577 | 577 |
let cins, couts = split_arrow cfun in |
578 | 578 |
let cins = clock_list_of_clock cins in |
579 | 579 |
List.iter2 (clock_subtyping_arg env) args cins; |
580 |
unify_imported_clock (Some clock_reset) cfun; |
|
580 |
unify_imported_clock (Some clock_reset) cfun loc;
|
|
581 | 581 |
couts |
582 | 582 |
|
583 | 583 |
and clock_ident nocarrier env id loc = |
... | ... | |
589 | 589 |
let cr = new_carrier Carry_name (*Carry_const c*) ck.cscoped in |
590 | 590 |
let ckcarry = new_ck (Ccarrying (cr,ce)) ck.cscoped in |
591 | 591 |
try_unify ck ckcarry expr_c.expr_loc; |
592 |
cr |
|
592 |
ce, cr
|
|
593 | 593 |
|
594 | 594 |
(** [clock_expr env expr] performs the clock calculus for expression [expr] in |
595 | 595 |
environment [env] *) |
... | ... | |
632 | 632 |
let ck_c = clock_standard_args env [c] in |
633 | 633 |
let ck = clock_standard_args env [t; e] in |
634 | 634 |
(* Here, the branches may exhibit a tuple clock, not the condition *) |
635 |
unify_tuple_clock (Some ck_c) ck; |
|
635 |
unify_tuple_clock (Some ck_c) ck expr.expr_loc;
|
|
636 | 636 |
expr.expr_clock <- ck; |
637 | 637 |
ck |
638 | 638 |
| Expr_appl (id, args, r) -> |
... | ... | |
656 | 656 |
| Expr_fby (e1,e2) |
657 | 657 |
| Expr_arrow (e1,e2) -> |
658 | 658 |
let ck = clock_standard_args env [e1; e2] in |
659 |
unify_tuple_clock None ck; |
|
659 |
unify_tuple_clock None ck expr.expr_loc;
|
|
660 | 660 |
expr.expr_clock <- ck; |
661 | 661 |
ck |
662 | 662 |
| Expr_pre e -> (* todo : deal with phases as in tail ? *) |
... | ... | |
666 | 666 |
| Expr_when (e,c,l) -> |
667 | 667 |
let ce = clock_standard_args env [e] in |
668 | 668 |
let c_loc = loc_of_cond expr.expr_loc c in |
669 |
let cr = clock_carrier env c c_loc ce in |
|
669 |
let ck_c, cr = clock_carrier env c c_loc ce in
|
|
670 | 670 |
let ck = new_ck (Con (ce,cr,l)) true in |
671 | 671 |
let cr' = new_carrier (Carry_const c) ck.cscoped in |
672 | 672 |
let ck' = new_ck (Con (ce,cr',l)) true in |
673 |
unify_tuple_clock (Some ck_c) ce expr.expr_loc; |
|
673 | 674 |
expr.expr_clock <- ck'; |
674 | 675 |
ck |
675 | 676 |
| Expr_merge (c,hl) -> |
676 | 677 |
let cvar = new_var true in |
677 |
let cr = clock_carrier env c expr.expr_loc cvar in |
|
678 |
let ck_c, cr = clock_carrier env c expr.expr_loc cvar in
|
|
678 | 679 |
List.iter (fun (t, h) -> clock_subtyping_arg env h (new_ck (Con (cvar,cr,t)) true)) hl; |
680 |
unify_tuple_clock (Some ck_c) cvar expr.expr_loc; |
|
679 | 681 |
expr.expr_clock <- cvar; |
680 | 682 |
cvar |
681 | 683 |
in |
... | ... | |
759 | 761 |
let ck_ins = clock_of_vlist nd.node_inputs in |
760 | 762 |
let ck_outs = clock_of_vlist nd.node_outputs in |
761 | 763 |
let ck_node = new_ck (Carrow (ck_ins,ck_outs)) false in |
762 |
unify_imported_clock None ck_node; |
|
764 |
unify_imported_clock None ck_node loc;
|
|
763 | 765 |
Log.report ~level:3 (fun fmt -> print_ck fmt ck_node); |
764 | 766 |
(* Local variables may contain first-order carrier variables that should be generalized. |
765 | 767 |
That's not the case for types. *) |
... | ... | |
810 | 812 |
let ck_ins = clock_of_vlist nd.nodei_inputs in |
811 | 813 |
let ck_outs = clock_of_vlist nd.nodei_outputs in |
812 | 814 |
let ck_node = new_ck (Carrow (ck_ins,ck_outs)) false in |
813 |
unify_imported_clock None ck_node; |
|
815 |
unify_imported_clock None ck_node loc;
|
|
814 | 816 |
check_imported_pclocks loc ck_node; |
815 | 817 |
try_generalize ck_node loc; |
816 | 818 |
nd.nodei_clock <- ck_node; |
src/liveness.ml | ||
---|---|---|
15 | 15 |
open Graph |
16 | 16 |
open Causality |
17 | 17 |
|
18 |
(* Computes the last dependency |
|
19 |
*) |
|
20 |
|
|
21 |
(* Computes the death table of [node] wrt dep graph [g] and topological [sort]. |
|
22 |
The death table is a mapping: ident -> Set(ident) such that: |
|
23 |
death x is the set of local variables which get dead (i.e. unused) |
|
24 |
after x is evaluated, but were until live. |
|
25 |
let death_table node g sort = |
|
26 |
let death = Hashtbl.create 23 in |
|
27 |
let sort = ref (List.rev sort) in |
|
28 |
let buried = ref ISet.empty in |
|
29 |
begin |
|
30 |
buried := ExprDep.node_memory_variables node; |
|
31 |
buried := List.fold_left (fun dead (v : var_decl) -> ISet.add v.var_id dead) !buried node.node_outputs; |
|
32 |
(* We could also try to reuse input variables, due to C parameter copying semantics *) |
|
33 |
buried := List.fold_left (fun dead (v : var_decl) -> ISet.add v.var_id dead) !buried node.node_inputs; |
|
34 |
while (!sort <> []) |
|
35 |
do |
|
36 |
let head = List.hd !sort in |
|
37 |
let dead = IdentDepGraph.fold_succ |
|
38 |
(fun tgt dead -> if not (ExprDep.is_instance_var tgt || ISet.mem tgt !buried) then ISet.add tgt dead else dead) |
|
39 |
g head ISet.empty in |
|
40 |
buried := ISet.union !buried dead; |
|
41 |
Hashtbl.add death head dead; |
|
42 |
sort := List.tl !sort |
|
43 |
done; |
|
44 |
IdentDepGraph.clear g; |
|
45 |
death |
|
46 |
end |
|
47 |
*) |
|
48 |
|
|
49 | 18 |
(* computes the in-degree for each local variable of node [n], according to dep graph [g]. |
50 | 19 |
*) |
51 | 20 |
let compute_fanin n g = |
... | ... | |
88 | 57 |
(ISet.union outputs mems) |
89 | 58 |
(ISet.union inputs mems) |
90 | 59 |
|
60 |
(* checks whether a variable is aliasable, |
|
61 |
depending on its (address) type *) |
|
62 |
let is_aliasable var = |
|
63 |
Types.is_address_type var.var_type |
|
64 |
|
|
91 | 65 |
(* computes the set of potentially reusable variables. |
92 | 66 |
We don't reuse input variables, due to possible aliasing *) |
93 | 67 |
let node_reusable_variables node = |
... | ... | |
100 | 74 |
|
101 | 75 |
(* Recursively removes useless variables, |
102 | 76 |
i.e. variables that are current roots of the dep graph [g] |
103 |
and returns [locals] and [evaluated] such roots *) |
|
77 |
and returns [locals] and [evaluated] such roots |
|
78 |
- [locals] is the set of potentially reusable variables |
|
79 |
- [evaluated] is the set of already evaluated variables, |
|
80 |
wrt the scheduling |
|
81 |
*) |
|
104 | 82 |
let remove_local_roots locals evaluated g = |
105 | 83 |
let rem = ref true in |
106 | 84 |
let roots = ref Disjunction.CISet.empty in |
... | ... | |
117 | 95 |
end |
118 | 96 |
done; |
119 | 97 |
!roots |
120 |
|
|
121 |
(* checks whether a variable is aliasable, |
|
122 |
depending on its (address) type *) |
|
123 |
let is_aliasable var = |
|
124 |
Types.is_address_type var.var_type |
|
125 | 98 |
|
126 | 99 |
(* checks whether a variable [v] is an input of the [var] equation, with an address type. |
127 | 100 |
if so, [var] could not safely reuse/alias [v], should [v] be dead in the caller node, |
... | ... | |
132 | 105 |
match NodeDep.get_callee eq_var.eq_rhs with |
133 | 106 |
| None -> [] |
134 | 107 |
| Some (_, args) -> List.fold_right (fun e r -> match e.expr_desc with Expr_ident id -> id::r | _ -> r) args [] in |
135 |
fun v -> Types.is_address_type v.var_type && List.mem v.var_id inputs_var
|
|
108 |
fun v -> is_aliasable v && List.mem v.var_id inputs_var
|
|
136 | 109 |
|
137 |
(* merges two variables [v] and [v'] of graph [g].
|
|
138 |
[v] is replaced by [v']
|
|
110 |
(* replace variable [v] by [v'] in graph [g].
|
|
111 |
[v'] is a dead variable
|
|
139 | 112 |
*) |
140 |
let merge_in_dep_graph v v' g =
|
|
113 |
let replace_in_dep_graph v v' g =
|
|
141 | 114 |
begin |
142 | 115 |
IdentDepGraph.add_vertex g v'; |
143 | 116 |
IdentDepGraph.iter_succ (fun s -> IdentDepGraph.add_edge g v' s) g v; |
... | ... | |
145 | 118 |
IdentDepGraph.remove_vertex g v |
146 | 119 |
end |
147 | 120 |
|
121 |
type context = |
|
122 |
{ |
|
123 |
mutable evaluated : Disjunction.CISet.t; |
|
124 |
mutable quasi : Disjunction.CISet.t; |
|
125 |
mutable reusable : Disjunction.CISet.t; |
|
126 |
disjoint : (ident, Disjunction.CISet.t) Hashtbl.t; |
|
127 |
policy : (ident, var_decl) Hashtbl.t; |
|
128 |
} |
|
129 |
|
|
130 |
let pp_reuse_policy fmt policy = |
|
131 |
begin |
|
132 |
Format.fprintf fmt "{ /* reuse policy */@."; |
|
133 |
Hashtbl.iter (fun s t -> Format.fprintf fmt "%s -> %s@." s t.var_id) policy; |
|
134 |
Format.fprintf fmt "}@." |
|
135 |
end |
|
136 |
|
|
137 |
let pp_context fmt ctx = |
|
138 |
begin |
|
139 |
Format.fprintf fmt "{ /*BEGIN context */@."; |
|
140 |
Format.fprintf fmt "eval=%a;@." Disjunction.pp_ciset ctx.evaluated; |
|
141 |
Format.fprintf fmt "quasi=%a;@." Disjunction.pp_ciset ctx.quasi; |
|
142 |
Format.fprintf fmt "reusable=%a;@." Disjunction.pp_ciset ctx.reusable; |
|
143 |
Format.fprintf fmt "disjoint=%a;@." Disjunction.pp_disjoint_map ctx.disjoint; |
|
144 |
Format.fprintf fmt "policy=%a;@." pp_reuse_policy ctx.policy; |
|
145 |
Format.fprintf fmt "/* END context */ }@."; |
|
146 |
end |
|
147 |
|
|
148 |
let is_reusable_quasi var ctx q = |
|
149 |
(*Log.report ~level:6 (fun fmt -> Format.fprintf fmt "is_reusable_quasi@ var=%s %a q=%s@." var.var_id pp_context ctx q.var_id);*) |
|
150 |
let disjoint = Hashtbl.find ctx.disjoint var.var_id in |
|
151 |
let q = Hashtbl.find ctx.policy q.var_id in |
|
152 |
Disjunction.CISet.for_all |
|
153 |
(fun v -> (Hashtbl.find ctx.policy v.var_id = q) <= (Disjunction.CISet.mem v disjoint || Disjunction.CISet.mem v ctx.quasi)) |
|
154 |
ctx.evaluated |
|
155 |
|
|
156 |
let compute_reusable heads var ctx = |
|
157 |
let (reusable', quasi') = Disjunction.CISet.partition (fun q -> (not (List.mem q heads)) && is_reusable_quasi var ctx q) ctx.quasi |
|
158 |
in |
|
159 |
begin |
|
160 |
ctx.quasi <- quasi'; |
|
161 |
ctx.reusable <- Disjunction.CISet.fold (fun r' -> Disjunction.CISet.add (Hashtbl.find ctx.policy r'.var_id)) reusable' ctx.reusable; |
|
162 |
ctx.quasi <- Disjunction.CISet.diff ctx.quasi reusable'; |
|
163 |
ctx.evaluated <- Disjunction.CISet.diff ctx.evaluated reusable'; |
|
164 |
end |
|
165 |
|
|
148 | 166 |
(* computes the reusable dependencies of variable [var] in graph [g], |
149 | 167 |
once [var] has been evaluated |
150 |
[dead] is the set of evaluated and dead variables |
|
151 |
[eval] is the set of evaluated variables |
|
168 |
- [locals] is the set of potentially reusable variables |
|
169 |
- [evaluated] is the set of evaluated variables |
|
170 |
- [quasi] is the set of quasi-reusable variables |
|
171 |
- [reusable] is the set of dead/reusable dependencies of [var] in graph [g] |
|
172 |
- [policy] is the reuse map (which domain is [evaluated]) |
|
152 | 173 |
*) |
153 |
let compute_reusable_dependencies locals evaluated reusable var g = |
|
174 |
let compute_dependencies locals heads ctx g = |
|
175 |
begin |
|
176 |
(*Log.report ~level:6 (fun fmt -> Format.fprintf fmt "compute_reusable_dependencies %a %a %a %a@." Disjunction.pp_ciset locals Printers.pp_var_name var pp_context ctx pp_dep_graph g);*) |
|
177 |
List.iter (fun head -> IdentDepGraph.iter_succ (IdentDepGraph.remove_edge g head.var_id) g head.var_id) heads; |
|
178 |
ctx.quasi <- Disjunction.CISet.union (remove_local_roots locals ctx.evaluated g) ctx.quasi; |
|
179 |
List.iter (fun head -> compute_reusable heads head ctx) heads; |
|
180 |
end |
|
181 |
|
|
182 |
let compute_evaluated heads ctx = |
|
154 | 183 |
begin |
155 |
Log.report ~level:2 (fun fmt -> Format.fprintf fmt "compute_reusable_dependencies %a %a %a %a %a@." Disjunction.pp_ciset locals Disjunction.pp_ciset !evaluated Disjunction.pp_ciset !reusable Printers.pp_var_name var pp_dep_graph g); |
|
156 |
evaluated := Disjunction.CISet.add var !evaluated; |
|
157 |
IdentDepGraph.iter_succ (IdentDepGraph.remove_edge g var.var_id) g var.var_id; |
|
158 |
reusable := Disjunction.CISet.union (remove_local_roots locals !evaluated g) !reusable; |
|
184 |
List.iter (fun head -> ctx.evaluated <- Disjunction.CISet.add head ctx.evaluated) heads; |
|
159 | 185 |
end |
160 | 186 |
|
187 |
let compute_reuse node var ctx g = |
|
188 |
let aliasable = is_aliasable_input node var.var_id in |
|
189 |
let eligible v = Typing.eq_ground var.var_type v.var_type && not (aliasable v) in |
|
190 |
try |
|
191 |
let disj = Hashtbl.find ctx.disjoint var.var_id in |
|
192 |
let reuse = |
|
193 |
Hashtbl.find ctx.policy |
|
194 |
(Disjunction.CISet.max_elt (Disjunction.CISet.filter (fun v -> (eligible v) && (Disjunction.CISet.mem v ctx.evaluated) && not (Disjunction.CISet.mem v ctx.reusable)) disj)).var_id in |
|
195 |
begin |
|
196 |
ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated; |
|
197 |
Hashtbl.add ctx.policy var.var_id reuse; |
|
198 |
end |
|
199 |
with Not_found -> |
|
200 |
try |
|
201 |
let reuse = Hashtbl.find ctx.policy (Disjunction.CISet.choose (Disjunction.CISet.filter (fun v -> eligible v) ctx.reusable)).var_id in |
|
202 |
begin |
|
203 |
replace_in_dep_graph var.var_id reuse.var_id g; |
|
204 |
Disjunction.replace_in_disjoint_map ctx.disjoint var reuse; |
|
205 |
ctx.evaluated <- Disjunction.CISet.add reuse ctx.evaluated; |
|
206 |
ctx.reusable <- Disjunction.CISet.remove reuse ctx.reusable; |
|
207 |
Hashtbl.add ctx.policy var.var_id reuse; |
|
208 |
end |
|
209 |
with Not_found -> |
|
210 |
begin |
|
211 |
ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated; |
|
212 |
Hashtbl.add ctx.policy var.var_id var; |
|
213 |
end |
|
214 |
|
|
161 | 215 |
let compute_reuse_policy node schedule disjoint g = |
162 | 216 |
let locals = node_reusable_variables node in |
163 | 217 |
let sort = ref schedule in |
164 |
let evaluated = ref Disjunction.CISet.empty in |
|
165 |
let reusable = ref Disjunction.CISet.empty in |
|
166 |
let policy = Hashtbl.create 23 in |
|
218 |
let ctx = { evaluated = Disjunction.CISet.empty; |
|
219 |
quasi = Disjunction.CISet.empty; |
|
220 |
reusable = Disjunction.CISet.empty; |
|
221 |
disjoint = disjoint; |
|
222 |
policy = Hashtbl.create 23; } in |
|
167 | 223 |
while !sort <> [] |
168 | 224 |
do |
169 |
let head = get_node_var (List.hd !sort) node in |
|
170 |
compute_reusable_dependencies locals evaluated reusable head g; |
|
171 |
let aliasable = is_aliasable_input node head.var_id in |
|
172 |
let eligible v = Typing.eq_ground head.var_type v.var_type && not (aliasable v) in |
|
173 |
let reuse = |
|
174 |
try |
|
175 |
let disj = Hashtbl.find disjoint head.var_id in |
|
176 |
Disjunction.CISet.max_elt (Disjunction.CISet.filter (fun v -> (eligible v) && (Disjunction.CISet.mem v !evaluated) && not (Disjunction.CISet.mem v !reusable)) disj) |
|
177 |
with Not_found -> |
|
178 |
try |
|
179 |
Disjunction.CISet.choose (Disjunction.CISet.filter (fun v -> eligible v) !reusable) |
|
180 |
with Not_found -> head in |
|
181 |
reusable := Disjunction.CISet.remove reuse !reusable; |
|
182 |
Disjunction.replace_in_disjoint_map disjoint head reuse; |
|
183 |
merge_in_dep_graph head.var_id reuse.var_id g; |
|
184 |
Hashtbl.add policy head.var_id reuse; |
|
185 |
Log.report ~level:2 (fun fmt -> Format.fprintf fmt "reuse %s instead of %s@." reuse.var_id head.var_id); |
|
186 |
Log.report ~level:1 (fun fmt -> Format.fprintf fmt "new disjoint:%a@." Disjunction.pp_disjoint_map disjoint); |
|
187 |
Log.report ~level:2 |
|
225 |
Log.report ~level:6 (fun fmt -> Format.fprintf fmt "new context:%a@." pp_context ctx); |
|
226 |
Log.report ~level:6 |
|
227 |
(fun fmt -> Format.fprintf fmt "new dependency graph:%a@." pp_dep_graph g); |
|
228 |
let heads = List.map (fun v -> get_node_var v node) (List.hd !sort) in |
|
229 |
Log.report ~level:6 (fun fmt -> Format.fprintf fmt "NEW HEADS:"); |
|
230 |
List.iter (fun head -> Log.report ~level:2 (fun fmt -> Format.fprintf fmt "%s " head.var_id)) heads; |
|
231 |
Log.report ~level:6 (fun fmt -> Format.fprintf fmt "@."); |
|
232 |
Log.report ~level:6 (fun fmt -> Format.fprintf fmt "COMPUTE_DEPENDENCIES@."); |
|
233 |
compute_dependencies locals heads ctx g; |
|
234 |
Log.report ~level:6 (fun fmt -> Format.fprintf fmt "new context:%a@." pp_context ctx); |
|
235 |
Log.report ~level:6 |
|
188 | 236 |
(fun fmt -> Format.fprintf fmt "new dependency graph:%a@." pp_dep_graph g); |
237 |
Log.report ~level:6 (fun fmt -> Format.fprintf fmt "COMPUTE_REUSE@."); |
|
238 |
List.iter (fun head -> compute_reuse node head ctx g) heads; |
|
239 |
List.iter (fun head -> Log.report ~level:6 (fun fmt -> Format.fprintf fmt "reuse %s instead of %s@." (Hashtbl.find ctx.policy head.var_id).var_id head.var_id)) heads; |
|
189 | 240 |
sort := List.tl !sort; |
190 | 241 |
done; |
191 | 242 |
IdentDepGraph.clear g; |
192 |
policy |
|
243 |
ctx.policy
|
|
193 | 244 |
|
194 | 245 |
(* Reuse policy: |
195 | 246 |
- could reuse variables with the same type exactly only (simple). |
... | ... | |
221 | 272 |
- not aliasable (i.e. address type) |
222 | 273 |
*) |
223 | 274 |
|
224 |
let pp_reuse_policy fmt policy = |
|
225 |
begin |
|
226 |
Format.fprintf fmt "{ /* reuse policy */@."; |
|
227 |
Hashtbl.iter (fun s t -> Format.fprintf fmt "%s -> %s@." s t.var_id) policy; |
|
228 |
Format.fprintf fmt "}@." |
|
229 |
end |
|
230 | 275 |
(* Local Variables: *) |
231 | 276 |
(* compile-command:"make -C .." *) |
232 | 277 |
(* End: *) |
src/machine_code.ml | ||
---|---|---|
361 | 361 |
NodeDep.filter_static_inputs (node_inputs node_f) el in |
362 | 362 |
let o = new_instance node node_f eq.eq_rhs.expr_tag in |
363 | 363 |
let call_ck = Clocks.new_var true in |
364 |
Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock; |
|
364 |
Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc;
|
|
365 | 365 |
(m, |
366 | 366 |
(if Stateless.check_node node_f then si else MReset o :: si), |
367 | 367 |
Utils.IMap.add o call_f j, |
... | ... | |
519 | 519 |
| None -> if m.mname.node_id = name then Some m else None) |
520 | 520 |
None machines |
521 | 521 |
|
522 |
(* variable substitution for optimizing purposes *) |
|
523 |
|
|
524 |
(* checks whether an [instr] is skip and can be removed from program *) |
|
525 |
let rec instr_is_skip instr = |
|
526 |
match instr with |
|
527 |
| MLocalAssign (i, LocalVar v) when i = v -> true |
|
528 |
| MStateAssign (i, StateVar v) when i = v -> true |
|
529 |
| MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl |
|
530 |
| _ -> false |
|
531 |
and instrs_are_skip instrs = |
|
532 |
List.for_all instr_is_skip instrs |
|
533 |
|
|
534 |
let instr_cons instr cont = |
|
535 |
if instr_is_skip instr then cont else instr::cont |
|
536 |
|
|
537 |
let rec instr_remove_skip instr cont = |
|
538 |
match instr with |
|
539 |
| MLocalAssign (i, LocalVar v) when i = v -> cont |
|
540 |
| MStateAssign (i, StateVar v) when i = v -> cont |
|
541 |
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont |
|
542 |
| _ -> instr::cont |
|
543 |
|
|
544 |
and instrs_remove_skip instrs cont = |
|
545 |
List.fold_right instr_remove_skip instrs cont |
|
546 |
|
|
547 |
let rec value_replace_var fvar value = |
|
548 |
match value with |
|
549 |
| Cst c -> value |
|
550 |
| LocalVar v -> LocalVar (fvar v) |
|
551 |
| StateVar v -> value |
|
552 |
| Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) |
|
553 |
| Array vl -> Array (List.map (value_replace_var fvar) vl) |
|
554 |
| Access (t, i) -> Access(value_replace_var fvar t, i) |
|
555 |
| Power (v, n) -> Power(value_replace_var fvar v, n) |
|
556 |
|
|
557 |
let rec instr_replace_var fvar instr cont = |
|
558 |
match instr with |
|
559 |
| MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont |
|
560 |
| MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont |
|
561 |
| MReset i -> instr_cons instr cont |
|
562 |
| MStep (il, i, vl) -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont |
|
563 |
| MBranch (g, hl) -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont |
|
564 |
|
|
565 |
and instrs_replace_var fvar instrs cont = |
|
566 |
List.fold_right (instr_replace_var fvar) instrs cont |
|
567 |
|
|
568 |
let step_replace_var fvar step = |
|
569 |
{ step with |
|
570 |
step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks; |
|
571 |
step_locals = Utils.remove_duplicates (List.map fvar step.step_locals); |
|
572 |
step_instrs = instrs_replace_var fvar step.step_instrs []; |
|
573 |
} |
|
574 |
|
|
575 |
let rec machine_replace_var fvar m = |
|
576 |
{ m with |
|
577 |
mstep = step_replace_var fvar m.mstep |
|
578 |
} |
|
579 |
|
|
580 |
let machine_reuse_var m reuse = |
|
581 |
let fvar v = |
|
582 |
try |
|
583 |
Hashtbl.find reuse v.var_id |
|
584 |
with Not_found -> v in |
|
585 |
machine_replace_var fvar m |
|
586 |
|
|
587 |
let prog_reuse_var prog node_schs = |
|
588 |
List.map |
|
589 |
(fun m -> |
|
590 |
machine_reuse_var m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table |
|
591 |
) prog |
|
592 | 522 |
|
593 | 523 |
(* Local Variables: *) |
594 | 524 |
(* compile-command:"make -C .." *) |
src/main_lustre_compiler.ml | ||
---|---|---|
260 | 260 |
and warns about unused input or memory variables *) |
261 | 261 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. scheduling@,"); |
262 | 262 |
let prog, node_schs = Scheduling.schedule_prog prog in |
263 |
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_warning_unused node_schs);
|
|
264 |
Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_schedule node_schs);
|
|
265 |
Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_fanin_table node_schs);
|
|
266 |
Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
|
|
263 |
Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_warning_unused node_schs);
|
|
264 |
Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_schedule node_schs);
|
|
265 |
Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_fanin_table node_schs);
|
|
266 |
Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
|
|
267 | 267 |
|
268 | 268 |
(* Optimization of prog: |
269 | 269 |
- Unfold consts |
... | ... | |
279 | 279 |
(* DFS with modular code generation *) |
280 | 280 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,"); |
281 | 281 |
let machine_code = Machine_code.translate_prog prog node_schs in |
282 |
(* experimental |
|
283 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization@,"); |
|
284 |
let machine_code = Machine_code.prog_reuse_var machine_code node_schs in |
|
285 |
*) |
|
286 |
Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," |
|
287 |
(Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine) |
|
288 |
machine_code); |
|
289 | 282 |
|
290 |
|
|
291 | 283 |
(* Optimize machine code *) |
292 | 284 |
let machine_code = |
293 |
if !Options.optimization >= 2 then |
|
294 |
Optimize_machine.optimize_machines machine_code |
|
285 |
if !Options.optimization >= 3 then |
|
286 |
begin |
|
287 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization@,"); |
|
288 |
Optimize_machine.machines_reuse_variables machine_code node_schs |
|
289 |
end |
|
295 | 290 |
else |
296 | 291 |
machine_code |
297 |
in |
|
298 |
|
|
292 |
in |
|
293 |
Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," |
|
294 |
(Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine) |
|
295 |
machine_code); |
|
296 |
|
|
299 | 297 |
(* Creating destination directory if needed *) |
300 | 298 |
if not (Sys.file_exists !Options.dest_dir) then ( |
301 | 299 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,"); |
src/normalization.ml | ||
---|---|---|
366 | 366 |
vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu |
367 | 367 |
) (vars, [], []) node.node_asserts in |
368 | 368 |
let new_locals = List.filter is_local vars in |
369 |
(* Compute tracebaility info:
|
|
369 |
(* Compute traceability info:
|
|
370 | 370 |
- gather newly bound variables |
371 | 371 |
- compute the associated expression without aliases |
372 | 372 |
*) |
src/optimize_machine.ml | ||
---|---|---|
117 | 117 |
let optimize_machines machines = |
118 | 118 |
List.map optimize_machine machines |
119 | 119 |
|
120 |
(* variable substitution for optimizing purposes *) |
|
121 |
|
|
122 |
(* checks whether an [instr] is skip and can be removed from program *) |
|
123 |
let rec instr_is_skip instr = |
|
124 |
match instr with |
|
125 |
| MLocalAssign (i, LocalVar v) when i = v -> true |
|
126 |
| MStateAssign (i, StateVar v) when i = v -> true |
|
127 |
| MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl |
|
128 |
| _ -> false |
|
129 |
and instrs_are_skip instrs = |
|
130 |
List.for_all instr_is_skip instrs |
|
131 |
|
|
132 |
let instr_cons instr cont = |
|
133 |
if instr_is_skip instr then cont else instr::cont |
|
134 |
|
|
135 |
let rec instr_remove_skip instr cont = |
|
136 |
match instr with |
|
137 |
| MLocalAssign (i, LocalVar v) when i = v -> cont |
|
138 |
| MStateAssign (i, StateVar v) when i = v -> cont |
|
139 |
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont |
|
140 |
| _ -> instr::cont |
|
141 |
|
|
142 |
and instrs_remove_skip instrs cont = |
|
143 |
List.fold_right instr_remove_skip instrs cont |
|
144 |
|
|
145 |
let rec value_replace_var fvar value = |
|
146 |
match value with |
|
147 |
| Cst c -> value |
|
148 |
| LocalVar v -> LocalVar (fvar v) |
|
149 |
| StateVar v -> value |
|
150 |
| Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) |
|
151 |
| Array vl -> Array (List.map (value_replace_var fvar) vl) |
|
152 |
| Access (t, i) -> Access(value_replace_var fvar t, i) |
|
153 |
| Power (v, n) -> Power(value_replace_var fvar v, n) |
|
154 |
|
|
155 |
let rec instr_replace_var fvar instr cont = |
|
156 |
match instr with |
|
157 |
| MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont |
|
158 |
| MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont |
|
159 |
| MReset i -> instr_cons instr cont |
|
160 |
| MStep (il, i, vl) -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont |
|
161 |
| MBranch (g, hl) -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont |
|
162 |
|
|
163 |
and instrs_replace_var fvar instrs cont = |
|
164 |
List.fold_right (instr_replace_var fvar) instrs cont |
|
165 |
|
|
166 |
let step_replace_var fvar step = |
|
167 |
(* Some outputs may have been replaced by locals. |
|
168 |
We then need to rename those outputs |
|
169 |
without changing their clocks, etc *) |
|
170 |
let outputs' = |
|
171 |
List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in |
|
172 |
let locals' = |
|
173 |
List.fold_left (fun res l -> |
|
174 |
let l' = fvar l in |
|
175 |
if List.exists (fun o -> o.var_id = l'.var_id) outputs' |
|
176 |
then res |
|
177 |
else Utils.add_cons l' res) |
|
178 |
[] step.step_locals in |
|
179 |
{ step with |
|
180 |
step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks; |
|
181 |
step_outputs = outputs'; |
|
182 |
step_locals = locals'; |
|
183 |
step_instrs = instrs_replace_var fvar step.step_instrs []; |
|
184 |
} |
|
185 |
|
|
186 |
let rec machine_replace_variables fvar m = |
|
187 |
{ m with |
|
188 |
mstep = step_replace_var fvar m.mstep |
|
189 |
} |
|
190 |
|
|
191 |
let machine_reuse_variables m reuse = |
|
192 |
let fvar v = |
|
193 |
try |
|
194 |
Hashtbl.find reuse v.var_id |
|
195 |
with Not_found -> v in |
|
196 |
machine_replace_variables fvar m |
|
197 |
|
|
198 |
let machines_reuse_variables prog node_schs = |
|
199 |
List.map |
|
200 |
(fun m -> |
|
201 |
machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table |
|
202 |
) prog |
|
203 |
|
|
120 | 204 |
|
121 | 205 |
(* Local Variables: *) |
122 | 206 |
(* compile-command:"make -C .." *) |
src/scheduling.ml | ||
---|---|---|
152 | 152 |
Disjunction.pp_disjoint_map disjoint |
153 | 153 |
); |
154 | 154 |
|
155 |
let reuse = Hashtbl.create 23 (*Liveness.compute_reuse_policy n sort disjoint gg*) in
|
|
155 |
let reuse = Liveness.compute_reuse_policy n sort disjoint gg in
|
|
156 | 156 |
Log.report ~level:2 |
157 | 157 |
(fun fmt -> |
158 | 158 |
Format.fprintf fmt |
src/utils.ml | ||
---|---|---|
43 | 43 |
| None -> None |
44 | 44 |
| Some e -> Some (f e) |
45 | 45 |
|
46 |
let add_cons x l = |
|
47 |
if List.mem x l then l else x::l |
|
48 |
|
|
46 | 49 |
let rec remove_duplicates l = |
47 | 50 |
match l with |
48 | 51 |
| [] -> [] |
49 |
| t::q -> if List.mem t q then remove_duplicates q else t :: remove_duplicates q
|
|
52 |
| t::q -> add_cons t (remove_duplicates q)
|
|
50 | 53 |
|
51 | 54 |
let position pred l = |
52 | 55 |
let rec pos p l = |
Also available in: Unified diff