Project

General

Profile

Revision 1837ce98

View differences:

src/causality.ml
141 141
let node_output_variables nd =
142 142
 List.fold_left (fun outputs v -> ISet.add v.var_id outputs) ISet.empty nd.node_outputs
143 143

  
144
let node_auxiliary_variables nd =
145
 ISet.diff (node_local_variables nd) (node_memory_variables nd)
146

  
144 147
let node_variables nd =
145 148
  let inputs = node_input_variables nd in
146 149
  let inoutputs = List.fold_left (fun inoutputs v -> ISet.add v.var_id inoutputs) inputs nd.node_outputs in
......
452 455

  
453 456
  (* map: var |-> list of disjoint vars, sorted in increasing branch length order,
454 457
     maybe removing shorter branches *)
455
  type clock_map = (ident, var_decl list) Hashtbl.t
458
  type clock_map = (ident, ident list) Hashtbl.t
456 459

  
457 460
  let clock_disjoint_map vdecls =
458 461
    let map = Hashtbl.create 23 in
......
460 463
      List.iter
461 464
	(fun v1 -> let disj_v1 =
462 465
		     List.fold_left
463
		       (fun res v2 -> if Clocks.disjoint v1.var_clock v2.var_clock then CISet.add v2 res else res)
464
		       CISet.empty
466
		       (fun res v2 -> if Clocks.disjoint v1.var_clock v2.var_clock then ISet.add v2.var_id res else res)
467
		       ISet.empty
465 468
		       vdecls in
466 469
		   (* disjoint vdecls are stored in increasing branch length order *)
467 470
		   Hashtbl.add map v1.var_id disj_v1)
......
470 473
    end
471 474

  
472 475
  (* replace variable [v] by [v'] in disjunction [map]. Then:
473
     - the mapping v |-> ... disappears
474
     - the mapping v' becomes v' |-> (map v) inter (map v')
475
     - other mappings become x |-> (map x) \ (if v in x then v else v')
476
      - the mapping v' becomes v' |-> (map v) inter (map v')
477
      - the mapping v |-> ... then disappears
478
      - other mappings become x |-> (map x) \ (if v in x then v else v')
479
     
476 480
  *)
477 481
  let replace_in_disjoint_map map v v' =
478 482
    begin
479
      Hashtbl.remove map v.var_id;
480
      Hashtbl.replace map v'.var_id (CISet.inter (Hashtbl.find map v.var_id) (Hashtbl.find map v'.var_id));
481
      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
      Hashtbl.replace map v' (ISet.inter (Hashtbl.find map v) (Hashtbl.find map v'));
484
      Hashtbl.remove map v;
485
      Hashtbl.iter (fun x map_x -> Hashtbl.replace map x (ISet.remove (if ISet.mem v map_x then v else v') map_x)) map;
482 486
    end
483 487

  
484 488
  let pp_disjoint_map fmt map =
485 489
    begin
486 490
      Format.fprintf fmt "{ /* disjoint map */@.";
487
      Hashtbl.iter (fun k v -> Format.fprintf fmt "%s # { %a }@." k (Utils.fprintf_list ~sep:", " Printers.pp_var_name) (CISet.elements v)) map;
491
      Hashtbl.iter (fun k v -> Format.fprintf fmt "%s # { %a }@." k (Utils.fprintf_list ~sep:", " Format.pp_print_string) (ISet.elements v)) map;
488 492
      Format.fprintf fmt "}@."
489 493
    end
490 494
end
src/corelang.ml
29 29
module VDeclModule =
30 30
struct (* Node module *)
31 31
  type t = var_decl
32
  let compare v1 v2 = compare v1 v2
33
  let hash n = Hashtbl.hash n
34
  let equal n1 n2 = n1 = n2
32
  let compare v1 v2 = compare v1.var_id v2.var_id
35 33
end
36 34

  
37 35
module VMap = Map.Make(VDeclModule)
......
301 299

  
302 300
let expr_list_of_expr expr =
303 301
  match expr.expr_desc with
304
  | Expr_tuple elist ->
305
      elist
306
  | _ -> [expr]
302
  | Expr_tuple elist -> elist
303
  | _                -> [expr]
307 304

  
308 305
let expr_of_expr_list loc elist =
309 306
 match elist with
src/liveness.ml
184 184
let replace_in_death_table death v v' =
185 185
 Hashtbl.iter (fun k dead -> Hashtbl.replace death k (replace_in_set dead v v')) death
186 186

  
187
let find_compatible_local node var dead =
187
let find_compatible_local node var dead death disjoint policy =
188 188
 (*Format.eprintf "find_compatible_local %s %s %a@." node.node_id var pp_iset dead;*)
189 189
  let typ = (get_node_var var node).var_type in
190 190
  let eq_var = get_node_eq var node in
191
  let locals = node.node_locals in
191 192
  let aliasable_inputs =
192 193
    match NodeDep.get_callee eq_var.eq_rhs with
193 194
    | None           -> []
194 195
    | Some (_, args) -> List.fold_right (fun e r -> match e.expr_desc with Expr_ident id -> id::r | _ -> r) args [] in
195
  let filter v =
196
  let filter base (v : var_decl) =
196 197
    let res =
197
       ISet.mem v.var_id dead
198
       base v
198 199
    && Typing.eq_ground typ v.var_type
199
    && not (Types.is_address_type v.var_type  && List.mem v.var_id aliasable_inputs) in
200
    && not (Types.is_address_type v.var_type && List.mem v.var_id aliasable_inputs) in
200 201
    begin
201 202
      (*Format.eprintf "filter %a = %s@." Printers.pp_var_name v (if res then "true" else "false");*)
202 203
      res
203 204
    end in
205
(*Format.eprintf "reuse %s@." var;*)
204 206
  try
205
    Some ((List.find filter node.node_locals).var_id)
206
  with Not_found -> None
207
    let disj = Hashtbl.find disjoint var in
208
    let reuse = List.find (filter (fun v -> ISet.mem v.var_id disj && not (ISet.mem v.var_id dead))) locals in
209
(*Format.eprintf "reuse %s by %s@." var reuse.var_id;*)
210
    Disjunction.replace_in_disjoint_map disjoint var reuse.var_id;
211
(*Format.eprintf "new disjoint:%a@." Disjunction.pp_disjoint_map disjoint;*)
212
    Hashtbl.add policy var reuse.var_id
213
  with Not_found ->
214
  try
215
    let reuse = List.find (filter (fun v -> ISet.mem v.var_id dead)) locals in
216
(*Format.eprintf "reuse %s by %s@." var reuse.var_id;*)
217
    replace_in_death_table death var reuse.var_id;
218
(*Format.eprintf "new death:%a@." pp_death_table death;*)
219
    Hashtbl.add policy var reuse.var_id
220
  with Not_found -> ()
207 221

  
208
let reuse_policy node sort death =
222
(* the reuse policy seeks to use less local variables
223
   by replacing local variables, applying the rules
224
   in the following order:
225
    1) use another clock disjoint still live variable,
226
       with the greatest possible disjoint clock
227
    2) reuse a dead variable
228
   For the sake of safety, we replace variables by others:
229
    - with the same type
230
    - not aliasable (i.e. address type)
231
*)
232
let reuse_policy node sort death disjoint =
209 233
  let dead = ref ISet.empty in
210 234
  let policy = Hashtbl.create 23 in
211 235
  let sort = ref sort in
......
216 240
      begin
217 241
	dead := ISet.union (Hashtbl.find death head) !dead;
218 242
      end;
219
    (match find_compatible_local node head !dead with
220
    | None   -> ()
221
    | Some l -> replace_in_death_table death head l; Hashtbl.add policy head l);
243
    find_compatible_local node head !dead death disjoint policy;
222 244
    sort := List.tl !sort;
223 245
  done;
224 246
  policy
src/machine_code.ml
377 377

  
378 378
  | p  , Expr_appl (f, arg, r) when not (Basic_library.is_internal_fun f) ->
379 379
    let var_p = List.map (fun v -> get_node_var v node) p in
380
    let el =
381
      match arg.expr_desc with
382
      | Expr_tuple el -> el
383
      | _             -> [arg] in
380
    let el = expr_list_of_expr arg in
384 381
    let vl = List.map (translate_expr node args) el in
385 382
    let node_f = node_from_name f in
386 383
    let call_f =
......
504 501
      | None -> if m.mname.node_id = name then Some m else None)
505 502
    None machines
506 503
    
504
(* variable substitution for optimizing purposes *)
505

  
506
(* checks whether an [instr] is skip and can be removed from program *)
507
let rec instr_is_skip instr =
508
  match instr with
509
  | MLocalAssign (i, LocalVar v) when i = v -> true
510
  | MStateAssign (i, StateVar v) when i = v -> true
511
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
512
  | _               -> false
513
and instrs_are_skip instrs =
514
  List.for_all instr_is_skip instrs
515

  
516
let rec instr_remove_skip instr cont =
517
  match instr with
518
  | MLocalAssign (i, LocalVar v) when i = v -> cont
519
  | MStateAssign (i, StateVar v) when i = v -> cont
520
  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
521
  | _               -> instr::cont
522

  
523
and instrs_remove_skip instrs cont =
524
  List.fold_right instr_remove_skip instrs cont
525

  
526
let rec value_replace_var fvar value =
527
  match value with
528
  | Cst c -> value
529
  | LocalVar v -> LocalVar (fvar v)
530
  | StateVar v -> value
531
  | Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) 
532
  | Array vl -> Array (List.map (value_replace_var fvar) vl)
533
  | Access (t, i) -> Access(value_replace_var fvar t, i)
534
  | Power (v, n) -> Power(value_replace_var fvar v, n)
535

  
536
let rec instr_replace_var fvar instr =
537
  match instr with
538
  | MLocalAssign (i, v) -> MLocalAssign (fvar i, value_replace_var fvar v)
539
  | MStateAssign (i, v) -> MStateAssign (i, value_replace_var fvar v)
540
  | MReset i            -> instr
541
  | MStep (il, i, vl)   -> MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)
542
  | MBranch (g, hl)     -> MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il)) hl)
543

  
544
and instrs_replace_var fvar instrs =
545
  List.map (instr_replace_var fvar) instrs
546

  
547
let step_replace_var fvar step =
548
  { step with
549
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
550
    step_locals = Utils.remove_duplicates (List.map fvar step.step_locals);
551
    step_instrs = instrs_replace_var fvar step.step_instrs;
552
}
553

  
554
let rec machine_replace_var fvar m =
555
  { m with
556
    mstep = step_replace_var fvar m.mstep
557
  }
558

  
559
let machine_reuse_var m reuse =
560
  let reuse_vdecl = Hashtbl.create 23 in
561
  begin
562
    Hashtbl.iter (fun v v' -> Hashtbl.add reuse_vdecl (get_node_var v m.mname) (get_node_var v' m.mname)) reuse;
563
    let fvar v =
564
      try
565
	Hashtbl.find reuse_vdecl v
566
      with Not_found -> v in
567
    machine_replace_var fvar m
568
  end
569

  
570
let prog_reuse_var prog node_schs =
571
  List.map 
572
    (fun m -> 
573
      machine_reuse_var m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table
574
    ) prog
507 575

  
508 576
(* Local Variables: *)
509 577
(* compile-command:"make -C .." *)
src/main_lustre_compiler.ml
296 296
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
297 297
    machine_code);
298 298

  
299
  (* experimental
300
  let machine_code = Machine_code.prog_reuse_var machine_code node_schs in
301
  *)
299 302
  (* Optimize machine code *)
300 303
  let machine_code = 
301 304
    if !Options.optimization >= 2 then
src/optimize_machine.ml
45 45
  (* When optimization >= 3, we also inline any basic operator call. 
46 46
     All those are returning a single ouput *)
47 47
  | MStep([v], id, vl) when
48
      List.mem id Basic_library.internal_funs 
48
      Basic_library.is_internal_fun id
49 49
      && !Options.optimization >= 3
50 50
      -> 	  assert false 
51 51
(*    true, apply elim v (Fun(id, vl))*)
......
53 53
    
54 54
  | MLocalAssign (v, ((Fun (id, il)) as e)) when 
55 55
      not (List.mem v outputs) 
56
      && List.mem id Basic_library.internal_funs (* this will avoid inlining ite *)
56
      && Basic_library.is_internal_fun id (* this will avoid inlining ite *)
57 57
      && !Options.optimization >= 3 
58 58
	-> (
59 59
(*	  Format.eprintf "WE STORE THE EXPRESSION DEFINING %s TO ELIMINATE IT@." v.var_id; *)
src/scheduling.ml
37 37
  unused_vars : ISet.t;
38 38
  (* the table mapping each local var to its in-degree *)
39 39
  fanin_table : (ident, int) Hashtbl.t;
40
  (* the table mapping each assignment to a set of dead/reusable variables *)
41
  death_table : (ident, ISet.t) Hashtbl.t
40
  (* the table mapping each assignment to a reusable variable *)
41
  reuse_table : (ident, ident) Hashtbl.t
42 42
}
43 43

  
44 44
(* Topological sort with a priority for variables belonging in the same equation lhs.
......
162 162
	  Disjunction.pp_disjoint_map disjoint
163 163
      );
164 164

  
165
    let reuse = Liveness.reuse_policy n sort death in
165
    let reuse = Liveness.reuse_policy n sort death disjoint in
166 166
    Log.report ~level:5 
167 167
      (fun fmt -> 
168 168
	Format.eprintf 
......
171 171
	  Liveness.pp_reuse_policy reuse
172 172
      );
173 173
 
174
    n', { schedule = sort; unused_vars = unused; fanin_table = fanin; death_table = death }
174
    n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse }
175 175
  with (Causality.Cycle v) as exc ->
176 176
    pp_error Format.err_formatter v;
177 177
    raise exc
src/utils.ml
53 53
  | None   -> None
54 54
  | Some e -> Some (f e)
55 55

  
56
let rec remove_duplicates l =
57
 match l with
58
 | [] -> []
59
 | t::q -> if List.mem t q then remove_duplicates q else t :: remove_duplicates q
60

  
56 61
let position pred l =
57 62
  let rec pos p l =
58 63
    match l with

Also available in: Unified diff