Project

General

Profile

« Previous | Next » 

Revision 2863281f

Added by Pierre-Loïc Garoche almost 7 years ago

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

View differences:

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