Project

General

Profile

Revision 45c13277

View differences:

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