Revision 2863281f
Added by Pierre-Loïc Garoche almost 7 years ago
src/arrow.ml | ||
---|---|---|
1 |
open Lustre_types |
|
2 |
|
|
3 |
let arrow_id = "_arrow" |
|
4 |
|
|
5 |
let arrow_typ = Types.new_ty Types.Tunivar |
|
6 |
|
|
7 |
let arrow_desc = |
|
8 |
{ |
|
9 |
node_id = arrow_id; |
|
10 |
node_type = Type_predef.type_bin_poly_op; |
|
11 |
node_clock = Clock_predef.ck_bin_univ; |
|
12 |
node_inputs= [Corelang.dummy_var_decl "_in1" arrow_typ; Corelang.dummy_var_decl "_in2" arrow_typ]; |
|
13 |
node_outputs= [Corelang.dummy_var_decl "_out" arrow_typ]; |
|
14 |
node_locals= []; |
|
15 |
node_gencalls = []; |
|
16 |
node_checks = []; |
|
17 |
node_asserts = []; |
|
18 |
node_stmts= []; |
|
19 |
node_dec_stateless = false; |
|
20 |
node_stateless = Some false; |
|
21 |
node_spec = None; |
|
22 |
node_annot = []; } |
|
23 |
|
|
24 |
let arrow_top_decl = |
|
25 |
{ |
|
26 |
top_decl_desc = Node arrow_desc; |
|
27 |
top_decl_owner = (Options_management.core_dependency "arrow"); |
|
28 |
top_decl_itf = false; |
|
29 |
top_decl_loc = Location.dummy_loc |
|
30 |
} |
src/arrow.mli | ||
---|---|---|
1 |
val arrow_id: string |
|
2 |
val arrow_top_decl: Lustre_types.top_decl |
|
3 |
val arrow_desc: Lustre_types.node_desc |
src/backends/C/c_backend.ml | ||
---|---|---|
48 | 48 |
(match !Options.main_node with |
49 | 49 |
| "" -> () (* No main node: we do not generate main *) |
50 | 50 |
| main_node -> ( |
51 |
match Machine_code.get_machine_opt main_node machines with |
|
51 |
match Machine_code_common.get_machine_opt main_node machines with
|
|
52 | 52 |
| None -> begin |
53 | 53 |
Global.main_node := main_node; |
54 | 54 |
Format.eprintf "Code generation error: %a@." Error.pp_error_msg Error.Main_not_found; |
... | ... | |
70 | 70 |
| "" -> () |
71 | 71 |
| mauve -> ( |
72 | 72 |
(* looking for the main node *) |
73 |
match Machine_code.get_machine_opt mauve machines with |
|
73 |
match Machine_code_common.get_machine_opt mauve machines with
|
|
74 | 74 |
| None -> begin |
75 | 75 |
Global.main_node := mauve; |
76 | 76 |
Format.eprintf "Code generation error: %a@." Error.pp_error_msg Error.Main_not_found; |
src/backends/C/c_backend_common.ml | ||
---|---|---|
13 | 13 |
open Lustre_types |
14 | 14 |
open Corelang |
15 | 15 |
open Machine_code_types |
16 |
open Machine_code_common |
|
16 | 17 |
|
17 | 18 |
|
18 | 19 |
let print_version fmt = |
... | ... | |
194 | 195 |
but an offset suffix may be added for array variables |
195 | 196 |
*) |
196 | 197 |
let rec pp_c_val self pp_var fmt v = |
197 |
let open Machine_code_types in |
|
198 | 198 |
match v.value_desc with |
199 | 199 |
| Cst c -> pp_c_const fmt c |
200 | 200 |
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl |
201 | 201 |
| Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i |
202 |
| Power (v, n) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." Machine_code.pp_val v; assert false)
|
|
202 |
| Power (v, n) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false) |
|
203 | 203 |
| LocalVar v -> pp_var fmt v |
204 | 204 |
| StateVar v -> |
205 | 205 |
(* array memory vars are represented by an indirection to a local var with the right type, |
... | ... | |
219 | 219 |
(* mpfr_t is a static array, not treated as general arrays *) |
220 | 220 |
if Types.is_address_type id.var_type |
221 | 221 |
then |
222 |
if Machine_code.is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
|
|
222 |
if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr) |
|
223 | 223 |
then fprintf fmt "(*%s)" id.var_id |
224 | 224 |
else fprintf fmt "%s" id.var_id |
225 | 225 |
else |
226 |
if Machine_code.is_output m id
|
|
226 |
if is_output m id |
|
227 | 227 |
then fprintf fmt "*%s" id.var_id |
228 | 228 |
else fprintf fmt "%s" id.var_id |
229 | 229 |
|
... | ... | |
237 | 237 |
then |
238 | 238 |
fprintf fmt "%s" id.var_id |
239 | 239 |
else |
240 |
if Machine_code.is_output m id
|
|
240 |
if is_output m id |
|
241 | 241 |
then |
242 | 242 |
fprintf fmt "%s" id.var_id |
243 | 243 |
else |
... | ... | |
274 | 274 |
then |
275 | 275 |
Format.fprintf fmt "%a = %a" |
276 | 276 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
277 |
(pp_c_val "" (pp_c_var_read m)) (Machine_code.get_const_assign m id)
|
|
277 |
(pp_c_val "" (pp_c_var_read m)) (get_const_assign m id) |
|
278 | 278 |
else |
279 | 279 |
Format.fprintf fmt "%a" |
280 | 280 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
... | ... | |
322 | 322 |
() |
323 | 323 |
|
324 | 324 |
let print_machine_struct fmt m = |
325 |
if fst (Machine_code.get_stateless_status m) then
|
|
325 |
if fst (get_stateless_status m) then |
|
326 | 326 |
begin |
327 | 327 |
end |
328 | 328 |
else |
... | ... | |
463 | 463 |
else |
464 | 464 |
fprintf fmt "&%s" id.var_id |
465 | 465 |
|
466 |
let pp_main_call mname self fmt m (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
|
|
467 |
if fst (Machine_code.get_stateless_status m)
|
|
466 |
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) = |
|
467 |
if fst (get_stateless_status m) |
|
468 | 468 |
then |
469 | 469 |
fprintf fmt "%a (%a%t%a);" |
470 | 470 |
pp_machine_step_name mname |
... | ... | |
481 | 481 |
self |
482 | 482 |
|
483 | 483 |
let pp_c_var m self pp_var fmt var = |
484 |
let open Machine_code_types in |
|
485 |
if Machine_code.is_memory m var |
|
484 |
if is_memory m var |
|
486 | 485 |
then |
487 |
pp_c_val self pp_var fmt (Machine_code.mk_val (StateVar var) var.var_type)
|
|
486 |
pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type) |
|
488 | 487 |
else |
489 |
pp_c_val self pp_var fmt (Machine_code.mk_val (LocalVar var) var.var_type)
|
|
488 |
pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type) |
|
490 | 489 |
|
491 | 490 |
|
492 | 491 |
let pp_array_suffix fmt loop_vars = |
... | ... | |
518 | 517 |
end |
519 | 518 |
|
520 | 519 |
let pp_const_initialize pp_var fmt const = |
521 |
let open Machine_code_types in |
|
522 |
let var = Machine_code.mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in |
|
520 |
let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in |
|
523 | 521 |
let rec aux indices value fmt typ = |
524 | 522 |
if Types.is_array_type typ |
525 | 523 |
then |
... | ... | |
574 | 572 |
end |
575 | 573 |
|
576 | 574 |
let pp_const_clear pp_var fmt const = |
577 |
let m = Machine_code.empty_machine in
|
|
575 |
let m = empty_machine in |
|
578 | 576 |
let var = Corelang.var_decl_of_const const in |
579 | 577 |
let rec aux indices fmt typ = |
580 | 578 |
if Types.is_array_type typ |
src/backends/C/c_backend_header.ml | ||
---|---|---|
13 | 13 |
open Lustre_types |
14 | 14 |
open Corelang |
15 | 15 |
open Machine_code_types |
16 |
open Machine_code_common |
|
16 | 17 |
open C_backend_common |
17 | 18 |
|
18 | 19 |
(********************************************************************************************) |
... | ... | |
22 | 23 |
|
23 | 24 |
module type MODIFIERS_HDR = |
24 | 25 |
sig |
25 |
val print_machine_decl_prefix: Format.formatter -> Machine_code_types.machine_t -> unit
|
|
26 |
val print_machine_decl_prefix: Format.formatter -> machine_t -> unit |
|
26 | 27 |
end |
27 | 28 |
|
28 | 29 |
module EmptyMod = |
... | ... | |
44 | 45 |
fprintf fmt "#include <mpfr.h>@." |
45 | 46 |
end; |
46 | 47 |
if !Options.cpp then |
47 |
fprintf fmt "#include \"%s/arrow.hpp\"@.@." Machine_code.arrow_top_decl.top_decl_owner
|
|
48 |
fprintf fmt "#include \"%s/arrow.hpp\"@.@." Arrow.arrow_top_decl.top_decl_owner
|
|
48 | 49 |
else |
49 |
fprintf fmt "#include \"%s/arrow.h\"@.@." Machine_code.arrow_top_decl.top_decl_owner
|
|
50 |
fprintf fmt "#include \"%s/arrow.h\"@.@." Arrow.arrow_top_decl.top_decl_owner
|
|
50 | 51 |
|
51 | 52 |
end |
52 | 53 |
|
53 | 54 |
let rec print_static_val pp_var fmt v = |
54 |
let open Machine_code_types in |
|
55 | 55 |
match v.value_desc with |
56 | 56 |
| Cst c -> pp_c_const fmt c |
57 | 57 |
| LocalVar v -> pp_var fmt v |
... | ... | |
62 | 62 |
Format.fprintf fmt "%s %a = %a" |
63 | 63 |
attr |
64 | 64 |
(pp_c_type (Format.sprintf "%s ## %s" inst v.var_id)) v.var_type |
65 |
(print_static_val pp_var) (Machine_code.get_const_assign m v)
|
|
65 |
(print_static_val pp_var) (get_const_assign m v) |
|
66 | 66 |
|
67 | 67 |
let print_static_constant_decl (m, attr, inst) fmt const_locals = |
68 | 68 |
let pp_var fmt v = |
... | ... | |
82 | 82 |
Format.fprintf fmt "%s ## %s" inst v.var_id |
83 | 83 |
else |
84 | 84 |
Format.fprintf fmt "%s" v.var_id in |
85 |
let values = List.map (Machine_code.value_of_dimension m) static in
|
|
85 |
let values = List.map (value_of_dimension m) static in |
|
86 | 86 |
fprintf fmt "%a(%s, %a%t%s)" |
87 | 87 |
pp_machine_static_declare_name (node_name n) |
88 | 88 |
attr |
... | ... | |
162 | 162 |
let print_machine_decl fmt m = |
163 | 163 |
begin |
164 | 164 |
Mod.print_machine_decl_prefix fmt m; |
165 |
if fst (Machine_code.get_stateless_status m) then
|
|
165 |
if fst (get_stateless_status m) then |
|
166 | 166 |
begin |
167 | 167 |
fprintf fmt "extern %a;@.@." |
168 | 168 |
print_stateless_prototype |
... | ... | |
211 | 211 |
|
212 | 212 |
let print_machine_alloc_decl fmt m = |
213 | 213 |
Mod.print_machine_decl_prefix fmt m; |
214 |
if fst (Machine_code.get_stateless_status m) then
|
|
214 |
if fst (get_stateless_status m) then |
|
215 | 215 |
begin |
216 | 216 |
end |
217 | 217 |
else |
src/backends/C/c_backend_main.ml | ||
---|---|---|
12 | 12 |
open Lustre_types |
13 | 13 |
open Machine_code_types |
14 | 14 |
open Corelang |
15 |
open Machine_code |
|
15 |
open Machine_code_common
|
|
16 | 16 |
open Format |
17 | 17 |
open C_backend_common |
18 | 18 |
open Utils |
src/backends/C/c_backend_src.ml | ||
---|---|---|
13 | 13 |
open Lustre_types |
14 | 14 |
open Machine_code_types |
15 | 15 |
open Corelang |
16 |
open Machine_code |
|
16 |
open Machine_code_common
|
|
17 | 17 |
open C_backend_common |
18 | 18 |
|
19 | 19 |
module type MODIFIERS_SRC = |
... | ... | |
146 | 146 |
( |
147 | 147 |
match loop_vars, value.value_desc with |
148 | 148 |
| (x, LAcc i) :: q, _ when is_const_index i -> |
149 |
let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in
|
|
149 |
let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in |
|
150 | 150 |
pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value |
151 | 151 |
| (_, LInt r) :: q, Cst (Const_array cl) -> |
152 | 152 |
let var_type = Types.array_element_type var_type in |
... | ... | |
175 | 175 |
then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars |
176 | 176 |
else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars |
177 | 177 |
| _ , Cst cst -> pp_c_const_suffix var_type fmt cst |
178 |
| _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars; assert false)
|
|
178 |
| _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type pp_val value pp_suffix loop_vars; assert false) |
|
179 | 179 |
) |
180 | 180 |
|
181 | 181 |
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution |
... | ... | |
611 | 611 |
print_global_init_prototype baseNAME |
612 | 612 |
(pp_c_basic_type_desc Type_predef.type_bool) |
613 | 613 |
(* constants *) |
614 |
(Utils.fprintf_list ~sep:"@," (pp_const_initialize (pp_c_var_read Machine_code.empty_machine))) constants
|
|
614 |
(Utils.fprintf_list ~sep:"@," (pp_const_initialize (pp_c_var_read empty_machine))) constants |
|
615 | 615 |
(Utils.pp_final_char_if_non_empty "@," dependencies) |
616 | 616 |
(* dependencies initialization *) |
617 | 617 |
(Utils.fprintf_list ~sep:"@," print_import_init) dependencies |
... | ... | |
623 | 623 |
print_global_clear_prototype baseNAME |
624 | 624 |
(pp_c_basic_type_desc Type_predef.type_bool) |
625 | 625 |
(* constants *) |
626 |
(Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read Machine_code.empty_machine))) constants
|
|
626 |
(Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read empty_machine))) constants |
|
627 | 627 |
(Utils.pp_final_char_if_non_empty "@," dependencies) |
628 | 628 |
(* dependencies initialization *) |
629 | 629 |
(Utils.fprintf_list ~sep:"@," print_import_clear) dependencies |
src/backends/EMF/EMF_backend.ml | ||
---|---|---|
100 | 100 |
|
101 | 101 |
open Lustre_types |
102 | 102 |
open Machine_code_types |
103 |
open Machine_code |
|
103 |
open Machine_code_common
|
|
104 | 104 |
open Format |
105 | 105 |
open EMF_common |
106 | 106 |
exception Unhandled of string |
... | ... | |
121 | 121 |
| MStep ([var], i, vl) -> |
122 | 122 |
( |
123 | 123 |
try |
124 |
let name = (Machine_code.get_node_def i m).node_id in
|
|
124 |
let name = (get_node_def i m).node_id in |
|
125 | 125 |
match name, vl with |
126 | 126 |
| "_arrow", [v1; v2] -> ( |
127 | 127 |
match v1.value_desc, v2.value_desc with |
... | ... | |
245 | 245 |
| _ -> assert false |
246 | 246 |
in |
247 | 247 |
let sorted_branches = List.sort sorting_branches branches in |
248 |
instrs @ (Machine_code.join_guards_list sorted_branches)
|
|
248 |
instrs @ (join_guards_list sorted_branches) |
|
249 | 249 |
|
250 | 250 |
let rec pp_emf_instr m fmt i = |
251 | 251 |
let pp_content fmt i = |
... | ... | |
340 | 340 |
) |
341 | 341 |
|
342 | 342 |
| MStep (outputs, f, inputs) when not (is_imported_node f m) -> ( |
343 |
let node_f = Machine_code.get_node_def f m in
|
|
343 |
let node_f = get_node_def f m in |
|
344 | 344 |
let is_stateful = List.mem_assoc f m.minstances in |
345 | 345 |
fprintf fmt "\"kind\": \"%s\",@ \"name\": \"%a\",@ \"id\": \"%s\",@ " |
346 | 346 |
(if is_stateful then "statefulcall" else "statelesscall") |
src/backends/EMF/EMF_common.ml | ||
---|---|---|
2 | 2 |
open Machine_code_types |
3 | 3 |
module VSet = Corelang.VSet |
4 | 4 |
open Format |
5 |
open Machine_code
|
|
5 |
open Machine_code_common
|
|
6 | 6 |
|
7 | 7 |
(* Matlab starting counting from 1. |
8 | 8 |
simple function to extract the element id in the list. Starts from 1. *) |
... | ... | |
221 | 221 |
fprintf fmt "\"datatype\": \"%a\"@ " pp_var_type v; |
222 | 222 |
fprintf fmt "@]}" |
223 | 223 |
) |
224 |
| _ -> eprintf "Not of cst or var: %a@." Machine_code.pp_val v ; assert false (* Invalid argument *)
|
|
224 |
| _ -> eprintf "Not of cst or var: %a@." pp_val v ; assert false (* Invalid argument *) |
|
225 | 225 |
|
226 | 226 |
|
227 | 227 |
let pp_emf_cst_or_var_list = |
src/backends/Horn/horn_backend_common.ml | ||
---|---|---|
113 | 113 |
List.fold_left (fun accu (id, (n, _)) -> |
114 | 114 |
let name = node_name n in |
115 | 115 |
if name = "_arrow" then |
116 |
let arrow_machine = Machine_code.arrow_machine in |
|
116 |
let arrow_machine = Machine_code_common.arrow_machine in
|
|
117 | 117 |
(rename_machine_list |
118 | 118 |
(concat prefix (concat (if fst then id else concat m.mname.node_id id) "_arrow")) |
119 | 119 |
arrow_machine.mmemory |
src/backends/Horn/horn_backend_printers.ml | ||
---|---|---|
19 | 19 |
open Lustre_types |
20 | 20 |
open Machine_code_types |
21 | 21 |
open Corelang |
22 |
open Machine_code |
|
22 |
open Machine_code_common
|
|
23 | 23 |
|
24 | 24 |
open Horn_backend_common |
25 | 25 |
|
... | ... | |
406 | 406 |
We first declare all variables then the two /rules/. |
407 | 407 |
*) |
408 | 408 |
let print_machine machines fmt m = |
409 |
if m.mname.node_id = arrow_id then |
|
409 |
if m.mname.node_id = Arrow.arrow_id then
|
|
410 | 410 |
(* We don't print arrow function *) |
411 | 411 |
() |
412 | 412 |
else |
... | ... | |
534 | 534 |
|
535 | 535 |
(*a function to print the rules in case we have an s-function*) |
536 | 536 |
let print_sfunction machines fmt m = |
537 |
if m.mname.node_id = arrow_id then |
|
537 |
if m.mname.node_id = Arrow.arrow_id then
|
|
538 | 538 |
(* We don't print arrow function *) |
539 | 539 |
() |
540 | 540 |
else |
src/compiler_stages.ml | ||
---|---|---|
233 | 233 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,"); |
234 | 234 |
let machine_code = Machine_code.translate_prog prog node_schs in |
235 | 235 |
|
236 |
Log.report ~level:3 (fun fmt -> fprintf fmt ".. generated machines (unoptimized):@ %a@ "Machine_code.pp_machines machine_code);
|
|
236 |
Log.report ~level:3 (fun fmt -> fprintf fmt ".. generated machines (unoptimized):@ %a@ " Machine_code_common.pp_machines machine_code);
|
|
237 | 237 |
|
238 | 238 |
(* Optimize machine code *) |
239 | 239 |
Optimize_machine.optimize prog node_schs machine_code |
... | ... | |
267 | 267 |
let source_out = open_out source_file in |
268 | 268 |
let fmt = formatter_of_out_channel source_out in |
269 | 269 |
Log.report ~level:1 (fun fmt -> fprintf fmt ".. hornification@,"); |
270 |
Horn_backend.translate fmt basename prog (Machine_code.arrow_machine::machine_code); |
|
270 |
Horn_backend.translate fmt basename prog (Machine_code_common.arrow_machine::machine_code);
|
|
271 | 271 |
(* Tracability file if option is activated *) |
272 | 272 |
if !Options.traces then ( |
273 | 273 |
let traces_file = destname ^ ".traces.xml" in (* Could be changed *) |
src/corelang.ml | ||
---|---|---|
55 | 55 |
var_clock = Clocks.new_var true; |
56 | 56 |
var_loc = loc } |
57 | 57 |
|
58 |
let dummy_var_decl name typ = |
|
59 |
{ |
|
60 |
var_id = name; |
|
61 |
var_orig = false; |
|
62 |
var_dec_type = dummy_type_dec; |
|
63 |
var_dec_clock = dummy_clock_dec; |
|
64 |
var_dec_const = false; |
|
65 |
var_dec_value = None; |
|
66 |
var_parent_nodeid = None; |
|
67 |
var_type = typ; |
|
68 |
var_clock = Clocks.new_ck Clocks.Cvar true; |
|
69 |
var_loc = Location.dummy_loc |
|
70 |
} |
|
71 |
|
|
58 | 72 |
let mkexpr loc d = |
59 | 73 |
{ expr_tag = Utils.new_tag (); |
60 | 74 |
expr_desc = d; |
... | ... | |
1157 | 1171 |
| Expr_ident _ -> false |
1158 | 1172 |
) |
1159 | 1173 |
|
1174 |
|
|
1175 |
|
|
1176 |
|
|
1160 | 1177 |
(* Local Variables: *) |
1161 | 1178 |
(* compile-command:"make -C .." *) |
1162 | 1179 |
(* End: *) |
src/corelang.mli | ||
---|---|---|
29 | 29 |
string option (* parent id *) |
30 | 30 |
-> var_decl |
31 | 31 |
|
32 |
val dummy_var_decl: ident -> Types.type_expr -> var_decl |
|
33 |
|
|
32 | 34 |
val var_decl_of_const: ?parentid:ident option -> const_desc -> var_decl |
33 | 35 |
val mkexpr: Location.t -> expr_desc -> expr |
34 | 36 |
val mkeq: Location.t -> ident list * expr -> eq |
src/machine_code.ml | ||
---|---|---|
11 | 11 |
|
12 | 12 |
open Lustre_types |
13 | 13 |
open Machine_code_types |
14 |
open Machine_code_common |
|
14 | 15 |
open Corelang |
15 | 16 |
open Clocks |
16 | 17 |
open Causality |
17 |
|
|
18 |
let print_statelocaltag = true |
|
19 | 18 |
|
20 | 19 |
exception NormalizationError |
21 | 20 |
|
22 | 21 |
|
23 |
let rec pp_val fmt v = |
|
24 |
match v.value_desc with |
|
25 |
| Cst c -> Printers.pp_const fmt c |
|
26 |
| LocalVar v -> |
|
27 |
if print_statelocaltag then |
|
28 |
Format.fprintf fmt "%s(L)" v.var_id |
|
29 |
else |
|
30 |
Format.pp_print_string fmt v.var_id |
|
31 |
|
|
32 |
| StateVar v -> |
|
33 |
if print_statelocaltag then |
|
34 |
Format.fprintf fmt "%s(S)" v.var_id |
|
35 |
else |
|
36 |
Format.pp_print_string fmt v.var_id |
|
37 |
| Array vl -> Format.fprintf fmt "[%a]" (Utils.fprintf_list ~sep:", " pp_val) vl |
|
38 |
| Access (t, i) -> Format.fprintf fmt "%a[%a]" pp_val t pp_val i |
|
39 |
| Power (v, n) -> Format.fprintf fmt "(%a^%a)" pp_val v pp_val n |
|
40 |
| Fun (n, vl) -> Format.fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " pp_val) vl |
|
41 |
|
|
42 |
let rec pp_instr fmt i = |
|
43 |
let _ = |
|
44 |
match i.instr_desc with |
|
45 |
| MLocalAssign (i,v) -> Format.fprintf fmt "%s<-l- %a" i.var_id pp_val v |
|
46 |
| MStateAssign (i,v) -> Format.fprintf fmt "%s<-s- %a" i.var_id pp_val v |
|
47 |
| MReset i -> Format.fprintf fmt "reset %s" i |
|
48 |
| MNoReset i -> Format.fprintf fmt "noreset %s" i |
|
49 |
| MStep (il, i, vl) -> |
|
50 |
Format.fprintf fmt "%a = %s (%a)" |
|
51 |
(Utils.fprintf_list ~sep:", " (fun fmt v -> Format.pp_print_string fmt v.var_id)) il |
|
52 |
i |
|
53 |
(Utils.fprintf_list ~sep:", " pp_val) vl |
|
54 |
| MBranch (g,hl) -> |
|
55 |
Format.fprintf fmt "@[<v 2>case(%a) {@,%a@,}@]" |
|
56 |
pp_val g |
|
57 |
(Utils.fprintf_list ~sep:"@," pp_branch) hl |
|
58 |
| MComment s -> Format.pp_print_string fmt s |
|
59 |
|
|
60 |
in |
|
61 |
(* Annotation *) |
|
62 |
(* let _ = *) |
|
63 |
(* match i.lustre_expr with None -> () | Some e -> Format.fprintf fmt " -- original expr: %a" Printers.pp_expr e *) |
|
64 |
(* in *) |
|
65 |
let _ = |
|
66 |
match i.lustre_eq with None -> () | Some eq -> Format.fprintf fmt " -- original eq: %a" Printers.pp_node_eq eq |
|
67 |
in |
|
68 |
() |
|
69 |
|
|
70 |
and pp_branch fmt (t, h) = |
|
71 |
Format.fprintf fmt "@[<v 2>%s:@,%a@]" t (Utils.fprintf_list ~sep:"@," pp_instr) h |
|
72 |
|
|
73 |
and pp_instrs fmt il = |
|
74 |
Format.fprintf fmt "@[<v 2>%a@]" (Utils.fprintf_list ~sep:"@," pp_instr) il |
|
75 |
|
|
76 |
|
|
77 |
(* merge log: get_node_def was in c0f8 *) |
|
78 |
(* Returns the node/machine associated to id in m calls *) |
|
79 |
let get_node_def id m = |
|
80 |
try |
|
81 |
let (decl, _) = List.assoc id m.mcalls in |
|
82 |
Corelang.node_of_top decl |
|
83 |
with Not_found -> ( |
|
84 |
(* Format.eprintf "Unable to find node %s in list [%a]@.@?" *) |
|
85 |
(* id *) |
|
86 |
(* (Utils.fprintf_list ~sep:", " (fun fmt (n,_) -> Format.fprintf fmt "%s" n)) m.mcalls *) |
|
87 |
(* ; *) |
|
88 |
raise Not_found |
|
89 |
) |
|
90 |
|
|
91 |
(* merge log: machine_vars was in 44686 *) |
|
92 |
let machine_vars m = m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory |
|
93 |
|
|
94 |
let pp_step fmt s = |
|
95 |
Format.fprintf fmt "@[<v>inputs : %a@ outputs: %a@ locals : %a@ checks : %a@ instrs : @[%a@]@ asserts : @[%a@]@]@ " |
|
96 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_inputs |
|
97 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_outputs |
|
98 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_locals |
|
99 |
(Utils.fprintf_list ~sep:", " (fun fmt (_, c) -> pp_val fmt c)) s.step_checks |
|
100 |
(Utils.fprintf_list ~sep:"@ " pp_instr) s.step_instrs |
|
101 |
(Utils.fprintf_list ~sep:", " pp_val) s.step_asserts |
|
102 |
|
|
103 |
|
|
104 |
let pp_static_call fmt (node, args) = |
|
105 |
Format.fprintf fmt "%s<%a>" |
|
106 |
(node_name node) |
|
107 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) args |
|
108 |
|
|
109 |
let pp_machine fmt m = |
|
110 |
Format.fprintf fmt |
|
111 |
"@[<v 2>machine %s@ mem : %a@ instances: %a@ init : %a@ const : %a@ step :@ @[<v 2>%a@]@ @ spec : @[%t@]@ annot : @[%a@]@]@ " |
|
112 |
m.mname.node_id |
|
113 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) m.mmemory |
|
114 |
(Utils.fprintf_list ~sep:", " (fun fmt (o1, o2) -> Format.fprintf fmt "(%s, %a)" o1 pp_static_call o2)) m.minstances |
|
115 |
(Utils.fprintf_list ~sep:"@ " pp_instr) m.minit |
|
116 |
(Utils.fprintf_list ~sep:"@ " pp_instr) m.mconst |
|
117 |
pp_step m.mstep |
|
118 |
(fun fmt -> match m.mspec with | None -> () | Some spec -> Printers.pp_spec fmt spec) |
|
119 |
(Utils.fprintf_list ~sep:"@ " Printers.pp_expr_annot) m.mannot |
|
120 |
|
|
121 |
let pp_machines fmt ml = |
|
122 |
Format.fprintf fmt "@[<v 0>%a@]" (Utils.fprintf_list ~sep:"@," pp_machine) ml |
|
123 |
|
|
124 |
|
|
125 |
let rec is_const_value v = |
|
126 |
match v.value_desc with |
|
127 |
| Cst _ -> true |
|
128 |
| Fun (id, args) -> Basic_library.is_value_internal_fun v && List.for_all is_const_value args |
|
129 |
| _ -> false |
|
130 |
|
|
131 |
(* Returns the declared stateless status and the computed one. *) |
|
132 |
let get_stateless_status m = |
|
133 |
(m.mname.node_dec_stateless, try Utils.desome m.mname.node_stateless with _ -> failwith ("stateless status of machine " ^ m.mname.node_id ^ " not computed")) |
|
134 |
|
|
135 |
let is_input m id = |
|
136 |
List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_inputs |
|
137 |
|
|
138 |
let is_output m id = |
|
139 |
List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs |
|
140 |
|
|
141 |
let is_memory m id = |
|
142 |
List.exists (fun o -> o.var_id = id.var_id) m.mmemory |
|
143 |
|
|
144 |
let conditional ?lustre_eq c t e = |
|
145 |
mkinstr ?lustre_eq:lustre_eq (MBranch(c, [ (tag_true, t); (tag_false, e) ])) |
|
146 |
|
|
147 |
let dummy_var_decl name typ = |
|
148 |
{ |
|
149 |
var_id = name; |
|
150 |
var_orig = false; |
|
151 |
var_dec_type = dummy_type_dec; |
|
152 |
var_dec_clock = dummy_clock_dec; |
|
153 |
var_dec_const = false; |
|
154 |
var_dec_value = None; |
|
155 |
var_parent_nodeid = None; |
|
156 |
var_type = typ; |
|
157 |
var_clock = Clocks.new_ck Clocks.Cvar true; |
|
158 |
var_loc = Location.dummy_loc |
|
159 |
} |
|
160 |
|
|
161 |
let arrow_id = "_arrow" |
|
162 |
|
|
163 |
let arrow_typ = Types.new_ty Types.Tunivar |
|
164 |
|
|
165 |
let arrow_desc = |
|
166 |
{ |
|
167 |
node_id = arrow_id; |
|
168 |
node_type = Type_predef.type_bin_poly_op; |
|
169 |
node_clock = Clock_predef.ck_bin_univ; |
|
170 |
node_inputs= [dummy_var_decl "_in1" arrow_typ; dummy_var_decl "_in2" arrow_typ]; |
|
171 |
node_outputs= [dummy_var_decl "_out" arrow_typ]; |
|
172 |
node_locals= []; |
|
173 |
node_gencalls = []; |
|
174 |
node_checks = []; |
|
175 |
node_asserts = []; |
|
176 |
node_stmts= []; |
|
177 |
node_dec_stateless = false; |
|
178 |
node_stateless = Some false; |
|
179 |
node_spec = None; |
|
180 |
node_annot = []; } |
|
181 |
|
|
182 |
let arrow_top_decl = |
|
183 |
{ |
|
184 |
top_decl_desc = Node arrow_desc; |
|
185 |
top_decl_owner = (Options_management.core_dependency "arrow"); |
|
186 |
top_decl_itf = false; |
|
187 |
top_decl_loc = Location.dummy_loc |
|
188 |
} |
|
189 |
|
|
190 |
let mk_val v t = |
|
191 |
{ value_desc = v; |
|
192 |
value_type = t; |
|
193 |
value_annot = None } |
|
194 |
|
|
195 |
let arrow_machine = |
|
196 |
let state = "_first" in |
|
197 |
let var_state = dummy_var_decl state Type_predef.type_bool(* (Types.new_ty Types.Tbool) *) in |
|
198 |
let var_input1 = List.nth arrow_desc.node_inputs 0 in |
|
199 |
let var_input2 = List.nth arrow_desc.node_inputs 1 in |
|
200 |
let var_output = List.nth arrow_desc.node_outputs 0 in |
|
201 |
let cst b = mk_val (Cst (const_of_bool b)) Type_predef.type_bool in |
|
202 |
let t_arg = Types.new_univar () in (* TODO Xavier: c'est bien la bonne def ? *) |
|
203 |
{ |
|
204 |
mname = arrow_desc; |
|
205 |
mmemory = [var_state]; |
|
206 |
mcalls = []; |
|
207 |
minstances = []; |
|
208 |
minit = [mkinstr (MStateAssign(var_state, cst true))]; |
|
209 |
mstatic = []; |
|
210 |
mconst = []; |
|
211 |
mstep = { |
|
212 |
step_inputs = arrow_desc.node_inputs; |
|
213 |
step_outputs = arrow_desc.node_outputs; |
|
214 |
step_locals = []; |
|
215 |
step_checks = []; |
|
216 |
step_instrs = [conditional (mk_val (StateVar var_state) Type_predef.type_bool) |
|
217 |
(List.map mkinstr |
|
218 |
[MStateAssign(var_state, cst false); |
|
219 |
MLocalAssign(var_output, mk_val (LocalVar var_input1) t_arg)]) |
|
220 |
(List.map mkinstr |
|
221 |
[MLocalAssign(var_output, mk_val (LocalVar var_input2) t_arg)]) ]; |
|
222 |
step_asserts = []; |
|
223 |
}; |
|
224 |
mspec = None; |
|
225 |
mannot = []; |
|
226 |
} |
|
227 |
|
|
228 |
let empty_desc = |
|
229 |
{ |
|
230 |
node_id = arrow_id; |
|
231 |
node_type = Types.bottom; |
|
232 |
node_clock = Clocks.bottom; |
|
233 |
node_inputs= []; |
|
234 |
node_outputs= []; |
|
235 |
node_locals= []; |
|
236 |
node_gencalls = []; |
|
237 |
node_checks = []; |
|
238 |
node_asserts = []; |
|
239 |
node_stmts= []; |
|
240 |
node_dec_stateless = true; |
|
241 |
node_stateless = Some true; |
|
242 |
node_spec = None; |
|
243 |
node_annot = []; } |
|
244 |
|
|
245 |
let empty_machine = |
|
246 |
{ |
|
247 |
mname = empty_desc; |
|
248 |
mmemory = []; |
|
249 |
mcalls = []; |
|
250 |
minstances = []; |
|
251 |
minit = []; |
|
252 |
mstatic = []; |
|
253 |
mconst = []; |
|
254 |
mstep = { |
|
255 |
step_inputs = []; |
|
256 |
step_outputs = []; |
|
257 |
step_locals = []; |
|
258 |
step_checks = []; |
|
259 |
step_instrs = []; |
|
260 |
step_asserts = []; |
|
261 |
}; |
|
262 |
mspec = None; |
|
263 |
mannot = []; |
|
264 |
} |
|
265 |
|
|
266 |
let new_instance = |
|
267 |
let cpt = ref (-1) in |
|
268 |
fun caller callee tag -> |
|
269 |
begin |
|
270 |
let o = |
|
271 |
if Stateless.check_node callee then |
|
272 |
node_name callee |
|
273 |
else |
|
274 |
Printf.sprintf "ni_%d" (incr cpt; !cpt) in |
|
275 |
let o = |
|
276 |
if !Options.ansi && is_generic_node callee |
|
277 |
then Printf.sprintf "%s_inst_%d" o (Utils.position (fun e -> e.expr_tag = tag) caller.node_gencalls) |
|
278 |
else o in |
|
279 |
o |
|
280 |
end |
|
281 |
|
|
282 |
|
|
283 | 22 |
(* translate_<foo> : node -> context -> <foo> -> machine code/expression *) |
284 | 23 |
(* the context contains m : state aka memory variables *) |
285 | 24 |
(* si : initialization instructions *) |
... | ... | |
325 | 64 |
[l, [inst]] ))) |
326 | 65 |
| _ -> inst |
327 | 66 |
|
328 |
let rec join_branches hl1 hl2 = |
|
329 |
match hl1, hl2 with |
|
330 |
| [] , _ -> hl2 |
|
331 |
| _ , [] -> hl1 |
|
332 |
| (t1, h1)::q1, (t2, h2)::q2 -> |
|
333 |
if t1 < t2 then (t1, h1) :: join_branches q1 hl2 else |
|
334 |
if t1 > t2 then (t2, h2) :: join_branches hl1 q2 |
|
335 |
else (t1, List.fold_right join_guards h1 h2) :: join_branches q1 q2 |
|
336 |
|
|
337 |
and join_guards inst1 insts2 = |
|
338 |
match get_instr_desc inst1, List.map get_instr_desc insts2 with |
|
339 |
| _ , [] -> |
|
340 |
[inst1] |
|
341 |
| MBranch (x1, hl1), MBranch (x2, hl2) :: q when x1 = x2 -> |
|
342 |
mkinstr |
|
343 |
(* TODO on pourrait uniquement concatener les lustres de inst1 et hd(inst2) *) |
|
344 |
(MBranch (x1, join_branches (sort_handlers hl1) (sort_handlers hl2))) |
|
345 |
:: (List.tl insts2) |
|
346 |
| _ -> inst1 :: insts2 |
|
347 |
|
|
348 |
let join_guards_list insts = |
|
349 |
List.fold_right join_guards insts [] |
|
350 | 67 |
|
351 | 68 |
(* specialize predefined (polymorphic) operators |
352 | 69 |
wrt their instances, so that the C semantics |
... | ... | |
413 | 130 |
let eq = Corelang.mkeq Location.dummy_loc ([y.var_id], expr) in |
414 | 131 |
match expr.expr_desc with |
415 | 132 |
| Expr_ite (c, t, e) -> let g = translate_guard node args c in |
416 |
conditional ?lustre_eq:(Some eq) g |
|
133 |
mk_conditional ?lustre_eq:(Some eq) g
|
|
417 | 134 |
[translate_act node args (y, t)] |
418 | 135 |
[translate_act node args (y, e)] |
419 | 136 |
| Expr_merge (x, hl) -> mkinstr ?lustre_eq:(Some eq) (MBranch (translate_ident node args x, |
... | ... | |
424 | 141 |
match r with |
425 | 142 |
| None -> [] |
426 | 143 |
| Some r -> let g = translate_guard node args r in |
427 |
[control_on_clock node args c (conditional g [mkinstr (MReset i)] [mkinstr (MNoReset i)])] |
|
144 |
[control_on_clock node args c (mk_conditional g [mkinstr (MReset i)] [mkinstr (MNoReset i)])]
|
|
428 | 145 |
|
429 | 146 |
let translate_eq node ((m, si, j, d, s) as args) eq = |
430 | 147 |
(* Format.eprintf "translate_eq %a with clock %a@." Printers.pp_node_eq eq Clocks.print_ck eq.eq_rhs.expr_clock; *) |
431 | 148 |
match eq.eq_lhs, eq.eq_rhs.expr_desc with |
432 | 149 |
| [x], Expr_arrow (e1, e2) -> |
433 | 150 |
let var_x = get_node_var x node in |
434 |
let o = new_instance node arrow_top_decl eq.eq_rhs.expr_tag in |
|
151 |
let o = new_instance node Arrow.arrow_top_decl eq.eq_rhs.expr_tag in
|
|
435 | 152 |
let c1 = translate_expr node args e1 in |
436 | 153 |
let c2 = translate_expr node args e2 in |
437 | 154 |
(m, |
438 | 155 |
mkinstr (MReset o) :: si, |
439 |
Utils.IMap.add o (arrow_top_decl, []) j, |
|
156 |
Utils.IMap.add o (Arrow.arrow_top_decl, []) j,
|
|
440 | 157 |
d, |
441 | 158 |
(control_on_clock node args eq.eq_rhs.expr_clock (mkinstr ?lustre_eq:(Some eq) (MStep ([var_x], o, [c1;c2])))) :: s) |
442 | 159 |
| [x], Expr_pre e1 when VSet.mem (get_node_var x node) d -> |
... | ... | |
661 | 378 |
translate_decl node sch |
662 | 379 |
) nodes |
663 | 380 |
|
664 |
let get_machine_opt name machines = |
|
665 |
List.fold_left |
|
666 |
(fun res m -> |
|
667 |
match res with |
|
668 |
| Some _ -> res |
|
669 |
| None -> if m.mname.node_id = name then Some m else None) |
|
670 |
None machines |
|
671 |
|
|
672 |
let get_const_assign m id = |
|
673 |
try |
|
674 |
match get_instr_desc (List.find |
|
675 |
(fun instr -> match get_instr_desc instr with |
|
676 |
| MLocalAssign (v, _) -> v == id |
|
677 |
| _ -> false) |
|
678 |
m.mconst |
|
679 |
) with |
|
680 |
| MLocalAssign (_, e) -> e |
|
681 |
| _ -> assert false |
|
682 |
with Not_found -> assert false |
|
683 |
|
|
684 |
|
|
685 |
let value_of_ident loc m id = |
|
686 |
(* is is a state var *) |
|
687 |
try |
|
688 |
let v = List.find (fun v -> v.var_id = id) m.mmemory |
|
689 |
in mk_val (StateVar v) v.var_type |
|
690 |
with Not_found -> |
|
691 |
try (* id is a node var *) |
|
692 |
let v = get_node_var id m.mname |
|
693 |
in mk_val (LocalVar v) v.var_type |
|
694 |
with Not_found -> |
|
695 |
try (* id is a constant *) |
|
696 |
let c = Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id)) |
|
697 |
in mk_val (LocalVar c) c.var_type |
|
698 |
with Not_found -> |
|
699 |
(* id is a tag *) |
|
700 |
let t = Const_tag id |
|
701 |
in mk_val (Cst t) (Typing.type_const loc t) |
|
702 |
|
|
703 |
(* type of internal fun used in dimension expression *) |
|
704 |
let type_of_value_appl f args = |
|
705 |
if List.mem f Basic_library.arith_funs |
|
706 |
then (List.hd args).value_type |
|
707 |
else Type_predef.type_bool |
|
708 |
|
|
709 |
let rec value_of_dimension m dim = |
|
710 |
match dim.Dimension.dim_desc with |
|
711 |
| Dimension.Dbool b -> |
|
712 |
mk_val (Cst (Const_tag (if b then Corelang.tag_true else Corelang.tag_false))) Type_predef.type_bool |
|
713 |
| Dimension.Dint i -> |
|
714 |
mk_val (Cst (Const_int i)) Type_predef.type_int |
|
715 |
| Dimension.Dident v -> value_of_ident dim.Dimension.dim_loc m v |
|
716 |
| Dimension.Dappl (f, args) -> |
|
717 |
let vargs = List.map (value_of_dimension m) args |
|
718 |
in mk_val (Fun (f, vargs)) (type_of_value_appl f vargs) |
|
719 |
| Dimension.Dite (i, t, e) -> |
|
720 |
(match List.map (value_of_dimension m) [i; t; e] with |
|
721 |
| [vi; vt; ve] -> mk_val (Fun ("ite", [vi; vt; ve])) vt.value_type |
|
722 |
| _ -> assert false) |
|
723 |
| Dimension.Dlink dim' -> value_of_dimension m dim' |
|
724 |
| _ -> assert false |
|
725 |
|
|
726 |
let rec dimension_of_value value = |
|
727 |
match value.value_desc with |
|
728 |
| Cst (Const_tag t) when t = Corelang.tag_true -> Dimension.mkdim_bool Location.dummy_loc true |
|
729 |
| Cst (Const_tag t) when t = Corelang.tag_false -> Dimension.mkdim_bool Location.dummy_loc false |
|
730 |
| Cst (Const_int i) -> Dimension.mkdim_int Location.dummy_loc i |
|
731 |
| LocalVar v -> Dimension.mkdim_ident Location.dummy_loc v.var_id |
|
732 |
| Fun (f, args) -> Dimension.mkdim_appl Location.dummy_loc f (List.map dimension_of_value args) |
|
733 |
| _ -> assert false |
|
734 | 381 |
|
735 | 382 |
(* Local Variables: *) |
736 | 383 |
(* compile-command:"make -C .." *) |
src/machine_code.mli | ||
---|---|---|
1 |
val pp_val: Format.formatter -> Machine_code_types.value_t -> unit |
|
2 |
val is_memory: Machine_code_types.machine_t -> Lustre_types.var_decl -> bool |
|
3 |
val is_output: Machine_code_types.machine_t -> Lustre_types.var_decl -> bool |
|
4 |
val is_const_value: Machine_code_types.value_t -> bool |
|
5 |
val get_const_assign: Machine_code_types.machine_t -> Lustre_types.var_decl -> Machine_code_types.value_t |
|
6 |
val get_stateless_status: Machine_code_types.machine_t -> bool * bool |
|
7 |
val mk_val: Machine_code_types.value_t_desc -> Types.type_expr -> Machine_code_types.value_t |
|
8 |
val empty_machine: Machine_code_types.machine_t |
|
9 |
val arrow_machine: Machine_code_types.machine_t |
|
10 |
val arrow_id: string |
|
11 |
val arrow_top_decl: Lustre_types.top_decl |
|
12 |
val value_of_dimension: Machine_code_types.machine_t -> Dimension.dim_expr -> Machine_code_types.value_t |
|
13 |
val dimension_of_value:Machine_code_types.value_t -> Dimension.dim_expr |
|
14 |
val pp_instr: Format.formatter -> Machine_code_types.instr_t -> unit |
|
15 |
val pp_instrs: Format.formatter -> Machine_code_types.instr_t list -> unit |
|
16 |
val pp_machines: Format.formatter -> Machine_code_types.machine_t list -> unit |
|
17 |
val get_machine_opt: string -> Machine_code_types.machine_t list -> Machine_code_types.machine_t option |
|
18 |
val get_node_def: string -> Machine_code_types.machine_t -> Lustre_types.node_desc |
|
19 |
val join_guards_list: Machine_code_types.instr_t list -> Machine_code_types.instr_t list |
|
20 | 1 |
val translate_prog: Lustre_types.program -> Scheduling.schedule_report Utils.IMap.t -> Machine_code_types.machine_t list |
src/machine_code_common.ml | ||
---|---|---|
1 |
open Lustre_types |
|
2 |
open Machine_code_types |
|
3 |
open Corelang |
|
4 |
|
|
5 |
let print_statelocaltag = true |
|
6 |
|
|
7 |
let rec pp_val fmt v = |
|
8 |
match v.value_desc with |
|
9 |
| Cst c -> Printers.pp_const fmt c |
|
10 |
| LocalVar v -> |
|
11 |
if print_statelocaltag then |
|
12 |
Format.fprintf fmt "%s(L)" v.var_id |
|
13 |
else |
|
14 |
Format.pp_print_string fmt v.var_id |
|
15 |
|
|
16 |
| StateVar v -> |
|
17 |
if print_statelocaltag then |
|
18 |
Format.fprintf fmt "%s(S)" v.var_id |
|
19 |
else |
|
20 |
Format.pp_print_string fmt v.var_id |
|
21 |
| Array vl -> Format.fprintf fmt "[%a]" (Utils.fprintf_list ~sep:", " pp_val) vl |
|
22 |
| Access (t, i) -> Format.fprintf fmt "%a[%a]" pp_val t pp_val i |
|
23 |
| Power (v, n) -> Format.fprintf fmt "(%a^%a)" pp_val v pp_val n |
|
24 |
| Fun (n, vl) -> Format.fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " pp_val) vl |
|
25 |
|
|
26 |
let rec pp_instr fmt i = |
|
27 |
let _ = |
|
28 |
match i.instr_desc with |
|
29 |
| MLocalAssign (i,v) -> Format.fprintf fmt "%s<-l- %a" i.var_id pp_val v |
|
30 |
| MStateAssign (i,v) -> Format.fprintf fmt "%s<-s- %a" i.var_id pp_val v |
|
31 |
| MReset i -> Format.fprintf fmt "reset %s" i |
|
32 |
| MNoReset i -> Format.fprintf fmt "noreset %s" i |
|
33 |
| MStep (il, i, vl) -> |
|
34 |
Format.fprintf fmt "%a = %s (%a)" |
|
35 |
(Utils.fprintf_list ~sep:", " (fun fmt v -> Format.pp_print_string fmt v.var_id)) il |
|
36 |
i |
|
37 |
(Utils.fprintf_list ~sep:", " pp_val) vl |
|
38 |
| MBranch (g,hl) -> |
|
39 |
Format.fprintf fmt "@[<v 2>case(%a) {@,%a@,}@]" |
|
40 |
pp_val g |
|
41 |
(Utils.fprintf_list ~sep:"@," pp_branch) hl |
|
42 |
| MComment s -> Format.pp_print_string fmt s |
|
43 |
|
|
44 |
in |
|
45 |
(* Annotation *) |
|
46 |
(* let _ = *) |
|
47 |
(* match i.lustre_expr with None -> () | Some e -> Format.fprintf fmt " -- original expr: %a" Printers.pp_expr e *) |
|
48 |
(* in *) |
|
49 |
let _ = |
|
50 |
match i.lustre_eq with None -> () | Some eq -> Format.fprintf fmt " -- original eq: %a" Printers.pp_node_eq eq |
|
51 |
in |
|
52 |
() |
|
53 |
|
|
54 |
and pp_branch fmt (t, h) = |
|
55 |
Format.fprintf fmt "@[<v 2>%s:@,%a@]" t (Utils.fprintf_list ~sep:"@," pp_instr) h |
|
56 |
|
|
57 |
and pp_instrs fmt il = |
|
58 |
Format.fprintf fmt "@[<v 2>%a@]" (Utils.fprintf_list ~sep:"@," pp_instr) il |
|
59 |
|
|
60 |
|
|
61 |
(* merge log: get_node_def was in c0f8 *) |
|
62 |
(* Returns the node/machine associated to id in m calls *) |
|
63 |
let get_node_def id m = |
|
64 |
try |
|
65 |
let (decl, _) = List.assoc id m.mcalls in |
|
66 |
Corelang.node_of_top decl |
|
67 |
with Not_found -> ( |
|
68 |
(* Format.eprintf "Unable to find node %s in list [%a]@.@?" *) |
|
69 |
(* id *) |
|
70 |
(* (Utils.fprintf_list ~sep:", " (fun fmt (n,_) -> Format.fprintf fmt "%s" n)) m.mcalls *) |
|
71 |
(* ; *) |
|
72 |
raise Not_found |
|
73 |
) |
|
74 |
|
|
75 |
(* merge log: machine_vars was in 44686 *) |
|
76 |
let machine_vars m = m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory |
|
77 |
|
|
78 |
let pp_step fmt s = |
|
79 |
Format.fprintf fmt "@[<v>inputs : %a@ outputs: %a@ locals : %a@ checks : %a@ instrs : @[%a@]@ asserts : @[%a@]@]@ " |
|
80 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_inputs |
|
81 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_outputs |
|
82 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_locals |
|
83 |
(Utils.fprintf_list ~sep:", " (fun fmt (_, c) -> pp_val fmt c)) s.step_checks |
|
84 |
(Utils.fprintf_list ~sep:"@ " pp_instr) s.step_instrs |
|
85 |
(Utils.fprintf_list ~sep:", " pp_val) s.step_asserts |
|
86 |
|
|
87 |
|
|
88 |
let pp_static_call fmt (node, args) = |
|
89 |
Format.fprintf fmt "%s<%a>" |
|
90 |
(node_name node) |
|
91 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) args |
|
92 |
|
|
93 |
let pp_machine fmt m = |
|
94 |
Format.fprintf fmt |
|
95 |
"@[<v 2>machine %s@ mem : %a@ instances: %a@ init : %a@ const : %a@ step :@ @[<v 2>%a@]@ @ spec : @[%t@]@ annot : @[%a@]@]@ " |
|
96 |
m.mname.node_id |
|
97 |
(Utils.fprintf_list ~sep:", " Printers.pp_var) m.mmemory |
|
98 |
(Utils.fprintf_list ~sep:", " (fun fmt (o1, o2) -> Format.fprintf fmt "(%s, %a)" o1 pp_static_call o2)) m.minstances |
|
99 |
(Utils.fprintf_list ~sep:"@ " pp_instr) m.minit |
|
100 |
(Utils.fprintf_list ~sep:"@ " pp_instr) m.mconst |
|
101 |
pp_step m.mstep |
|
102 |
(fun fmt -> match m.mspec with | None -> () | Some spec -> Printers.pp_spec fmt spec) |
|
103 |
(Utils.fprintf_list ~sep:"@ " Printers.pp_expr_annot) m.mannot |
|
104 |
|
|
105 |
let pp_machines fmt ml = |
|
106 |
Format.fprintf fmt "@[<v 0>%a@]" (Utils.fprintf_list ~sep:"@," pp_machine) ml |
|
107 |
|
|
108 |
|
|
109 |
let rec is_const_value v = |
|
110 |
match v.value_desc with |
|
111 |
| Cst _ -> true |
|
112 |
| Fun (id, args) -> Basic_library.is_value_internal_fun v && List.for_all is_const_value args |
|
113 |
| _ -> false |
|
114 |
|
|
115 |
(* Returns the declared stateless status and the computed one. *) |
|
116 |
let get_stateless_status m = |
|
117 |
(m.mname.node_dec_stateless, try Utils.desome m.mname.node_stateless with _ -> failwith ("stateless status of machine " ^ m.mname.node_id ^ " not computed")) |
|
118 |
|
|
119 |
let is_input m id = |
|
120 |
List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_inputs |
|
121 |
|
|
122 |
let is_output m id = |
|
123 |
List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs |
|
124 |
|
|
125 |
let is_memory m id = |
|
126 |
List.exists (fun o -> o.var_id = id.var_id) m.mmemory |
|
127 |
|
|
128 |
let mk_conditional ?lustre_eq c t e = |
|
129 |
mkinstr ?lustre_eq:lustre_eq (MBranch(c, [ (tag_true, t); (tag_false, e) ])) |
|
130 |
|
|
131 |
|
|
132 |
|
|
133 |
let mk_val v t = |
|
134 |
{ value_desc = v; |
|
135 |
value_type = t; |
|
136 |
value_annot = None } |
|
137 |
|
|
138 |
let arrow_machine = |
|
139 |
let state = "_first" in |
|
140 |
let var_state = dummy_var_decl state Type_predef.type_bool(* (Types.new_ty Types.Tbool) *) in |
|
141 |
let var_input1 = List.nth Arrow.arrow_desc.node_inputs 0 in |
|
142 |
let var_input2 = List.nth Arrow.arrow_desc.node_inputs 1 in |
|
143 |
let var_output = List.nth Arrow.arrow_desc.node_outputs 0 in |
|
144 |
let cst b = mk_val (Cst (const_of_bool b)) Type_predef.type_bool in |
|
145 |
let t_arg = Types.new_univar () in (* TODO Xavier: c'est bien la bonne def ? *) |
|
146 |
{ |
|
147 |
mname = Arrow.arrow_desc; |
|
148 |
mmemory = [var_state]; |
|
149 |
mcalls = []; |
|
150 |
minstances = []; |
|
151 |
minit = [mkinstr (MStateAssign(var_state, cst true))]; |
|
152 |
mstatic = []; |
|
153 |
mconst = []; |
|
154 |
mstep = { |
|
155 |
step_inputs = Arrow.arrow_desc.node_inputs; |
|
156 |
step_outputs = Arrow.arrow_desc.node_outputs; |
|
157 |
step_locals = []; |
|
158 |
step_checks = []; |
|
159 |
step_instrs = [mk_conditional (mk_val (StateVar var_state) Type_predef.type_bool) |
|
160 |
(List.map mkinstr |
|
161 |
[MStateAssign(var_state, cst false); |
|
162 |
MLocalAssign(var_output, mk_val (LocalVar var_input1) t_arg)]) |
|
163 |
(List.map mkinstr |
|
164 |
[MLocalAssign(var_output, mk_val (LocalVar var_input2) t_arg)]) ]; |
|
165 |
step_asserts = []; |
|
166 |
}; |
|
167 |
mspec = None; |
|
168 |
mannot = []; |
|
169 |
} |
|
170 |
|
|
171 |
let empty_desc = |
|
172 |
{ |
|
173 |
node_id = Arrow.arrow_id; |
|
174 |
node_type = Types.bottom; |
|
175 |
node_clock = Clocks.bottom; |
|
176 |
node_inputs= []; |
|
177 |
node_outputs= []; |
|
178 |
node_locals= []; |
|
179 |
node_gencalls = []; |
|
180 |
node_checks = []; |
|
181 |
node_asserts = []; |
|
182 |
node_stmts= []; |
|
183 |
node_dec_stateless = true; |
|
184 |
node_stateless = Some true; |
|
185 |
node_spec = None; |
|
186 |
node_annot = []; } |
|
187 |
|
|
188 |
let empty_machine = |
|
189 |
{ |
|
190 |
mname = empty_desc; |
|
191 |
mmemory = []; |
|
192 |
mcalls = []; |
|
193 |
minstances = []; |
|
194 |
minit = []; |
|
195 |
mstatic = []; |
|
196 |
mconst = []; |
|
197 |
mstep = { |
|
198 |
step_inputs = []; |
|
199 |
step_outputs = []; |
|
200 |
step_locals = []; |
|
201 |
step_checks = []; |
|
202 |
step_instrs = []; |
|
203 |
step_asserts = []; |
|
204 |
}; |
|
205 |
mspec = None; |
|
206 |
mannot = []; |
|
207 |
} |
|
208 |
|
|
209 |
let new_instance = |
|
210 |
let cpt = ref (-1) in |
|
211 |
fun caller callee tag -> |
|
212 |
begin |
|
213 |
let o = |
|
214 |
if Stateless.check_node callee then |
|
215 |
node_name callee |
|
216 |
else |
|
217 |
Printf.sprintf "ni_%d" (incr cpt; !cpt) in |
|
218 |
let o = |
|
219 |
if !Options.ansi && is_generic_node callee |
|
220 |
then Printf.sprintf "%s_inst_%d" o (Utils.position (fun e -> e.expr_tag = tag) caller.node_gencalls) |
|
221 |
else o in |
|
222 |
o |
|
223 |
end |
|
224 |
|
|
225 |
|
|
226 |
let get_machine_opt name machines = |
|
227 |
List.fold_left |
|
228 |
(fun res m -> |
|
229 |
match res with |
|
230 |
| Some _ -> res |
|
231 |
| None -> if m.mname.node_id = name then Some m else None) |
|
232 |
None machines |
|
233 |
|
|
234 |
let get_const_assign m id = |
|
235 |
try |
|
236 |
match get_instr_desc (List.find |
|
237 |
(fun instr -> match get_instr_desc instr with |
|
238 |
| MLocalAssign (v, _) -> v == id |
|
239 |
| _ -> false) |
|
240 |
m.mconst |
|
241 |
) with |
|
242 |
| MLocalAssign (_, e) -> e |
|
243 |
| _ -> assert false |
|
244 |
with Not_found -> assert false |
|
245 |
|
|
246 |
|
|
247 |
let value_of_ident loc m id = |
|
248 |
(* is is a state var *) |
|
249 |
try |
|
250 |
let v = List.find (fun v -> v.var_id = id) m.mmemory |
|
251 |
in mk_val (StateVar v) v.var_type |
|
252 |
with Not_found -> |
|
253 |
try (* id is a node var *) |
|
254 |
let v = get_node_var id m.mname |
|
255 |
in mk_val (LocalVar v) v.var_type |
|
256 |
with Not_found -> |
|
257 |
try (* id is a constant *) |
|
258 |
let c = Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id)) |
|
259 |
in mk_val (LocalVar c) c.var_type |
|
260 |
with Not_found -> |
|
261 |
(* id is a tag *) |
|
262 |
let t = Const_tag id |
|
263 |
in mk_val (Cst t) (Typing.type_const loc t) |
|
264 |
|
|
265 |
(* type of internal fun used in dimension expression *) |
|
266 |
let type_of_value_appl f args = |
|
267 |
if List.mem f Basic_library.arith_funs |
|
268 |
then (List.hd args).value_type |
|
269 |
else Type_predef.type_bool |
|
270 |
|
|
271 |
let rec value_of_dimension m dim = |
|
272 |
match dim.Dimension.dim_desc with |
|
273 |
| Dimension.Dbool b -> |
|
274 |
mk_val (Cst (Const_tag (if b then Corelang.tag_true else Corelang.tag_false))) Type_predef.type_bool |
|
275 |
| Dimension.Dint i -> |
|
276 |
mk_val (Cst (Const_int i)) Type_predef.type_int |
|
277 |
| Dimension.Dident v -> value_of_ident dim.Dimension.dim_loc m v |
|
278 |
| Dimension.Dappl (f, args) -> |
|
279 |
let vargs = List.map (value_of_dimension m) args |
|
280 |
in mk_val (Fun (f, vargs)) (type_of_value_appl f vargs) |
|
281 |
| Dimension.Dite (i, t, e) -> |
|
282 |
(match List.map (value_of_dimension m) [i; t; e] with |
|
283 |
| [vi; vt; ve] -> mk_val (Fun ("ite", [vi; vt; ve])) vt.value_type |
|
284 |
| _ -> assert false) |
|
285 |
| Dimension.Dlink dim' -> value_of_dimension m dim' |
|
286 |
| _ -> assert false |
|
287 |
|
|
288 |
let rec dimension_of_value value = |
|
289 |
match value.value_desc with |
|
290 |
| Cst (Const_tag t) when t = Corelang.tag_true -> Dimension.mkdim_bool Location.dummy_loc true |
|
291 |
| Cst (Const_tag t) when t = Corelang.tag_false -> Dimension.mkdim_bool Location.dummy_loc false |
|
292 |
| Cst (Const_int i) -> Dimension.mkdim_int Location.dummy_loc i |
|
293 |
| LocalVar v -> Dimension.mkdim_ident Location.dummy_loc v.var_id |
|
294 |
| Fun (f, args) -> Dimension.mkdim_appl Location.dummy_loc f (List.map dimension_of_value args) |
|
295 |
| _ -> assert false |
|
296 |
|
|
297 |
|
|
298 |
let rec join_branches hl1 hl2 = |
|
299 |
match hl1, hl2 with |
|
300 |
| [] , _ -> hl2 |
|
301 |
| _ , [] -> hl1 |
|
302 |
| (t1, h1)::q1, (t2, h2)::q2 -> |
|
303 |
if t1 < t2 then (t1, h1) :: join_branches q1 hl2 else |
|
304 |
if t1 > t2 then (t2, h2) :: join_branches hl1 q2 |
|
305 |
else (t1, List.fold_right join_guards h1 h2) :: join_branches q1 q2 |
|
306 |
|
|
307 |
and join_guards inst1 insts2 = |
|
308 |
match get_instr_desc inst1, List.map get_instr_desc insts2 with |
|
309 |
| _ , [] -> |
|
310 |
[inst1] |
|
311 |
| MBranch (x1, hl1), MBranch (x2, hl2) :: q when x1 = x2 -> |
|
312 |
mkinstr |
|
313 |
(* TODO on pourrait uniquement concatener les lustres de inst1 et hd(inst2) *) |
|
314 |
(MBranch (x1, join_branches (sort_handlers hl1) (sort_handlers hl2))) |
|
315 |
:: (List.tl insts2) |
|
316 |
| _ -> inst1 :: insts2 |
|
317 |
|
|
318 |
let join_guards_list insts = |
|
319 |
List.fold_right join_guards insts [] |
src/machine_code_common.mli | ||
---|---|---|
1 |
val pp_val: Format.formatter -> Machine_code_types.value_t -> unit |
|
2 |
val is_memory: Machine_code_types.machine_t -> Lustre_types.var_decl -> bool |
|
3 |
val is_output: Machine_code_types.machine_t -> Lustre_types.var_decl -> bool |
|
4 |
val is_const_value: Machine_code_types.value_t -> bool |
|
5 |
val get_const_assign: Machine_code_types.machine_t -> Lustre_types.var_decl -> Machine_code_types.value_t |
|
6 |
val get_stateless_status: Machine_code_types.machine_t -> bool * bool |
|
7 |
val mk_val: Machine_code_types.value_t_desc -> Types.type_expr -> Machine_code_types.value_t |
|
8 |
val mk_conditional: ?lustre_eq:Lustre_types.eq -> Machine_code_types.value_t -> Machine_code_types.instr_t list -> Machine_code_types.instr_t list -> Machine_code_types.instr_t |
|
9 |
val empty_machine: Machine_code_types.machine_t |
|
10 |
val arrow_machine: Machine_code_types.machine_t |
|
11 |
val new_instance: Lustre_types.node_desc -> Lustre_types.top_decl -> Lustre_types.tag -> Lustre_types.ident |
|
12 |
val value_of_dimension: Machine_code_types.machine_t -> Dimension.dim_expr -> Machine_code_types.value_t |
|
13 |
val dimension_of_value:Machine_code_types.value_t -> Dimension.dim_expr |
|
14 |
val pp_instr: Format.formatter -> Machine_code_types.instr_t -> unit |
|
15 |
val pp_instrs: Format.formatter -> Machine_code_types.instr_t list -> unit |
|
16 |
val pp_machines: Format.formatter -> Machine_code_types.machine_t list -> unit |
|
17 |
val get_machine_opt: string -> Machine_code_types.machine_t list -> Machine_code_types.machine_t option |
|
18 |
val get_node_def: string -> Machine_code_types.machine_t -> Lustre_types.node_desc |
|
19 |
val join_guards_list: Machine_code_types.instr_t list -> Machine_code_types.instr_t list |
src/main_lustre_compiler.ml | ||
---|---|---|
98 | 98 |
in |
99 | 99 |
|
100 | 100 |
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ "); |
101 |
Log.report ~level:3 (fun fmt -> fprintf fmt ".. Generated machines:@ %a@ "Machine_code.pp_machines machine_code);
|
|
101 |
Log.report ~level:3 (fun fmt -> fprintf fmt ".. Generated machines:@ %a@ " Machine_code_common.pp_machines machine_code);
|
|
102 | 102 |
|
103 | 103 |
if Scopes.Plugin.show_scopes () then |
104 | 104 |
begin |
src/mpfr.ml | ||
---|---|---|
14 | 14 |
open Machine_code_types |
15 | 15 |
open Corelang |
16 | 16 |
open Normalization |
17 |
open Machine_code |
|
17 |
open Machine_code_common
|
|
18 | 18 |
|
19 | 19 |
let mpfr_module = mktop (Open(false, "mpfr_lustre")) |
20 | 20 |
let cpt_fresh = ref 0 |
src/optimize_machine.ml | ||
---|---|---|
14 | 14 |
open Machine_code_types |
15 | 15 |
open Corelang |
16 | 16 |
open Causality |
17 |
open Machine_code
|
|
17 |
open Machine_code_common
|
|
18 | 18 |
open Dimension |
19 | 19 |
|
20 | 20 |
|
... | ... | |
228 | 228 |
let static_call_unfold elim (inst, (n, args)) = |
229 | 229 |
let replace v = |
230 | 230 |
try |
231 |
Machine_code.dimension_of_value (IMap.find v elim)
|
|
231 |
dimension_of_value (IMap.find v elim) |
|
232 | 232 |
with Not_found -> Dimension.mkdim_ident Location.dummy_loc v |
233 | 233 |
in (inst, (n, List.map (Dimension.expr_replace_expr replace) args)) |
234 | 234 |
|
... | ... | |
578 | 578 |
Log.report ~level:1 |
579 | 579 |
(fun fmt -> Format.fprintf fmt ".. machines optimization: sub-expression elimination@,"); |
580 | 580 |
let machine_code = machines_cse machine_code in |
581 |
Log.report ~level:3 (fun fmt -> Format.fprintf fmt ".. generated machines (sub-expr elim):@ %a@ "Machine_code.pp_machines machine_code);
|
|
581 |
Log.report ~level:3 (fun fmt -> Format.fprintf fmt ".. generated machines (sub-expr elim):@ %a@ "pp_machines machine_code); |
|
582 | 582 |
machine_code |
583 | 583 |
end |
584 | 584 |
else |
... | ... | |
593 | 593 |
let machine_code, removed_table = machines_unfold (Corelang.get_consts prog) node_schs machine_code in |
594 | 594 |
Log.report ~level:3 (fun fmt -> Format.fprintf fmt "\t@[Eliminated constants: @[%a@]@]@ " |
595 | 595 |
(pp_imap pp_elim) removed_table); |
596 |
Log.report ~level:3 (fun fmt -> Format.fprintf fmt ".. generated machines (const inlining):@ %a@ "Machine_code.pp_machines machine_code);
|
|
596 |
Log.report ~level:3 (fun fmt -> Format.fprintf fmt ".. generated machines (const inlining):@ %a@ "pp_machines machine_code); |
|
597 | 597 |
machine_code, removed_table |
598 | 598 |
end |
599 | 599 |
else |
src/plugins/salsa/machine_salsa_opt.ml | ||
---|---|---|
260 | 260 |
ranges, formalEnv, printed_vars, and remaining vars to be printed) *) |
261 | 261 |
let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv printed_vars vars_to_print = |
262 | 262 |
let formal_env_def = FormalEnv.def constEnv vars_env in |
263 |
Format.eprintf "Rewrite intrs :%a@." Machine_code.pp_instrs instrs;
|
|
263 |
Format.eprintf "Rewrite intrs :%a@." MC.pp_instrs instrs;
|
|
264 | 264 |
let assign_vars = assign_vars nodename m constEnv vars_env in |
265 | 265 |
if !debug then ( |
266 | 266 |
Format.eprintf "@.------------@ "; |
src/plugins/salsa/salsaDatatypes.ml | ||
---|---|---|
1 | 1 |
module LT = Lustre_types |
2 | 2 |
module MT = Machine_code_types |
3 |
module MC = Machine_code |
|
3 |
module MC = Machine_code_common
|
|
4 | 4 |
module ST = Salsa.Types |
5 | 5 |
module Float = Salsa.Float |
6 | 6 |
|
src/plugins/scopes/scopes.ml | ||
---|---|---|
1 | 1 |
open Lustre_types |
2 | 2 |
open Corelang |
3 | 3 |
open Machine_code_types |
4 |
open Machine_code |
|
4 |
open Machine_code_common
|
|
5 | 5 |
|
6 | 6 |
(* (variable, node name, node instance) *) |
7 | 7 |
type scope_t = (var_decl * string * string option) list * var_decl |
... | ... | |
107 | 107 |
let instance = |
108 | 108 |
List.find |
109 | 109 |
(fun i -> match get_instr_desc i with |
110 |
| Machine_code_types.MStep(p, o, _) -> List.exists find_var p
|
|
110 |
| MStep(p, o, _) -> List.exists find_var p |
|
111 | 111 |
| _ -> false |
112 | 112 |
) |
113 | 113 |
e_machine.mstep.step_instrs |
... | ... | |
115 | 115 |
try |
116 | 116 |
let variable, instance_node, instance_id = |
117 | 117 |
match get_instr_desc instance with |
118 |
| Machine_code_types.MStep(p, o, _) ->
|
|
118 |
| MStep(p, o, _) -> |
|
119 | 119 |
(* Format.eprintf "Looking for machine %s@.@?" o; *) |
120 | 120 |
let o_fun, _ = List.assoc o e_machine.mcalls in |
121 | 121 |
if node_name o_fun = nodename then |
... | ... | |
221 | 221 |
let update_machine machine = |
222 | 222 |
let stateassign vdecl = |
223 | 223 |
mkinstr |
224 |
(Machine_code_types.MStateAssign (vdecl, mk_val (Machine_code_types.LocalVar vdecl) vdecl.var_type))
|
|
224 |
(MStateAssign (vdecl, mk_val (LocalVar vdecl) vdecl.var_type))
|
|
225 | 225 |
in |
226 | 226 |
let local_decls = machine.mstep.step_inputs |
227 | 227 |
(* @ machine.mstep.step_outputs *) |
... | ... | |
232 | 232 |
mstep = { |
233 | 233 |
machine.mstep with |
234 | 234 |
step_instrs = machine.mstep.step_instrs |
235 |
@ (mkinstr (Machine_code_types.MComment "Registering all flows"))::(List.map stateassign local_decls)
|
|
235 |
@ (mkinstr (MComment "Registering all flows"))::(List.map stateassign local_decls) |
|
236 | 236 |
|
237 | 237 |
} |
238 | 238 |
} |
Also available in: Unified diff
Further restructuring:
- arrow.ml* to define basic builder for arrow (node, name, ...)
- machine_code_common similar to corelang but for machine_code (printers, some builders, ...)
- machine_code restricted to the translatation from normalized nodes to machines