Project

General

Profile

Revision add75bcb

View differences:

src/causality.ml
447 447
(* Module used to compute static disjunction of variables based upon their clocks. *)
448 448
module Disjunction =
449 449
struct
450
  (* map: var |-> list of disjoint vars, sorted in increasing branch length,
451
     maybe removing shorter branches *)
452
  type clock_map = (ident, ident list) Hashtbl.t
450
  module ClockedIdentModule =
451
  struct
452
    type t = var_decl
453
    let root_branch vdecl = Clocks.root vdecl.var_clock, Clocks.branch vdecl.var_clock
454
    let compare v1 v2 = compare (root_branch v2) (root_branch v1)
455
  end
456

  
457
  module CISet = Set.Make(ClockedIdentModule)
453 458

  
454
  let rec add_vdecl map vdecls =
455
    match vdecls with
456
    | []         -> ()
457
    | vdecl :: q -> begin
458
		      Hashtbl.add map vdecl.var_id (List.fold_left (fun r v -> if Clocks.disjoint v.var_clock vdecl.var_clock then v.var_id::r else r) [] q);
459
                      add_vdecl map q
460
		    end
459
  (* map: var |-> list of disjoint vars, sorted in increasing branch length order,
460
     maybe removing shorter branches *)
461
  type clock_map = (ident, var_decl list) Hashtbl.t
461 462

  
462 463
  let clock_disjoint_map vdecls =
463
    let root_branch vdecl = Clocks.root vdecl.var_clock, Clocks.branch vdecl.var_clock in
464 464
    let map = Hashtbl.create 23 in
465 465
    begin
466
      add_vdecl map (List.sort (fun v1 v2 -> compare (root_branch v1) (root_branch v2)) vdecls);
466
      List.iter
467
	(fun v1 -> let disj_v1 =
468
		     List.fold_left
469
		       (fun res v2 -> if Clocks.disjoint v1.var_clock v2.var_clock then CISet.add v2 res else res)
470
		       CISet.empty
471
		       vdecls in
472
		   (* disjoint vdecls are stored in increasing branch length order *)
473
		   Hashtbl.add map v1.var_id disj_v1)
474
	vdecls;
467 475
      map
468 476
    end
469 477

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

  
470 490
  let pp_disjoint_map fmt map =
471 491
    begin
472 492
      Format.fprintf fmt "{ /* disjoint map */@.";
473
      Hashtbl.iter (fun k v -> Format.fprintf fmt "%s # { %a }@." k (Utils.fprintf_list ~sep:", " Format.pp_print_string) v) map;
493
      Hashtbl.iter (fun k v -> Format.fprintf fmt "%s # { %a }@." k (Utils.fprintf_list ~sep:", " Printers.pp_var_name) (CISet.elements v)) map;
474 494
      Format.fprintf fmt "}@."
475 495
    end
476 496
end
src/corelang.ml
355 355

  
356 356
(* let get_const c = snd (Hashtbl.find consts_table c) *)
357 357

  
358
let ident_of_expr expr =
359
 match expr.expr_desc with
360
 | Expr_ident id -> id
361
 | _             -> assert false
362

  
358 363
(* Caution, returns an untyped and unclocked expression *)
359 364
let expr_of_ident id loc =
360 365
  {expr_tag = Utils.new_tag ();
src/corelang.mli
218 218

  
219 219
(* Caution, returns an untyped, unclocked, etc, expression *)
220 220
val is_tuple_expr : expr -> bool
221
val ident_of_expr : expr -> ident
221 222
val expr_of_ident : ident -> Location.t -> expr
222 223
val expr_list_of_expr : expr -> expr list
223 224
val expr_of_expr_list : Location.t -> expr list -> expr
src/main_lustre_compiler.ml
104 104
    let _ = open_in lusi_name in
105 105
    let header = load_lusi true lusi_name in
106 106
    let _, declared_types_env, declared_clocks_env = check_lusi header in
107
    
108
      (* checking type compatibility with computed types*)
107
        
108
    (* checking stateless status compatibility *)
109
    Stateless.check_compat header;
110

  
111
    (* checking type compatibility with computed types*)
109 112
    Typing.check_env_compat header declared_types_env computed_types_env;
110 113
    Typing.uneval_prog_generics prog;
111 114
    
112
      (* checking clocks compatibility with computed clocks*)
113
      Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
114
      Clock_calculus.uneval_prog_generics prog;
115
    (* checking clocks compatibility with computed clocks*)
116
    Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
117
    Clock_calculus.uneval_prog_generics prog
115 118

  
116
      (* checking stateless status compatibility *)
117
      Stateless.check_compat header
118 119
    with Sys_error _ -> ( 
119 120
      (* Printing lusi file is necessary *)
120 121
      Log.report ~level:1 
......
195 196
  
196 197
  (* Sorting nodes *)
197 198
  let prog = SortProg.sort prog in
198
  
199

  
200
  (* Checking stateless/stateful status *)
201
  check_stateless_decls prog;
202

  
199 203
  (* Typing *)
200 204
  let computed_types_env = type_decls type_env prog in
201 205
  
202 206
  (* Clock calculus *)
203 207
  let computed_clocks_env = clock_decls clock_env prog in
204 208

  
205
  (* Checking stateless/stateful status *)
206
  check_stateless_decls prog;
207

  
208 209
  (* Perform global inlining *)
209 210
  let prog =
210 211
    if !Options.global_inline && 
src/optimize_prog.ml
39 39
let node_unfold_consts consts node = 
40 40
  { node with node_eqs = List.map (eq_unfold_consts consts) node.node_eqs }
41 41

  
42

  
43

  
44 42
let prog_unfold_consts prog =
45 43
  let consts = get_consts prog in
46 44
    List.map (
......
49 47
	| _       -> decl
50 48
    ) prog 
51 49

  
50
let apply_stack expr stack =
51
 List.fold_left (fun expr (v, t) -> mkexpr expr.expr_loc (Expr_when (expr, v, t))) expr stack
52

  
53
let expr_distribute_when expr =
54
  let rec distrib stack expr =
55
    match expr.expr_desc with
56
    | Expr_const _
57
    | Expr_ident _
58
    | Expr_arrow _
59
    | Expr_fby _
60
    | Expr_pre _
61
	-> apply_stack expr stack
62
    | Expr_appl (id, _, _) when not (Stateless.check_node (node_from_name id))
63
	-> apply_stack expr stack
64
    | Expr_ite (c, t, e)
65
        -> let cid = ident_of_expr c in
66
           mkexpr expr.expr_loc
67
	     (Expr_merge (cid,
68
			  [(tag_true , distrib ((cid,tag_true )::stack) t);
69
			   (tag_false, distrib ((cid,tag_false)::stack) e)]))
70
    | Expr_array el -> { expr with expr_desc = (Expr_array (List.map (distrib stack) el)) }
71
    | Expr_access (e1, d) -> { expr with expr_desc = Expr_access (distrib stack e1, d) }
72
    | Expr_power (e1, d) -> { expr with expr_desc = Expr_power (distrib stack e1, d) }
73
    | Expr_tuple el -> { expr with expr_desc = Expr_tuple (List.map (distrib stack) el) }
74
    | Expr_when (e', i, l)-> distrib ((i, l)::stack) e'
75
    | Expr_merge (i, hl) -> { expr with expr_desc = Expr_merge (i, List.map (fun (t, h) -> (t, distrib stack h)) hl) }
76
    | Expr_appl (id, e', i') -> { expr with expr_desc = Expr_appl (id, distrib stack e', i')}
77
    | _ -> assert false
78
  in distrib [] expr
79

  
80
let eq_distribute_when eq =
81
  { eq with eq_rhs = expr_distribute_when eq.eq_rhs }
82

  
83
let node_distribute_when node =
84
  { node with node_eqs = List.map eq_distribute_when node.node_eqs }
85

  
86
let prog_distribute_when prog =
87
    List.map (
88
      fun decl -> match decl.top_decl_desc with 
89
	| Node nd -> {decl with top_decl_desc = Node (node_distribute_when nd)}
90
	| _       -> decl
91
    ) prog 
52 92
(* Local Variables: *)
53 93
(* compile-command:"make -C .." *)
54 94
(* End: *)

Also available in: Unified diff