Revision 7ecdb0aa
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 
(* compilecommand:"make C .." *) 
54  94 
(* End: *) 
Also available in: Unified diff