Project

General

Profile

Revision 2475c9e8

View differences:

src/backends/EMF/EMF_backend.ml
10 10
   
11 11

  
12 12
   In terms of algorithm, the process was initially based on printing normalized
13
   code. We now rely on machine code printing. The old code is preserved for
14
   reference.
15
*)
13
   code. We now rely on machine code printing. The old code is available in old
14
   commits (eg in dd71e482a9d0).
16 15

  
17
open LustreSpec
18
open Machine_code
19
open Format
20
open Utils
16
   
17
   A (normalized) node becomes a JSON struct
18
   node foo (in1, in2: int) returns (out1, out2: int);
19
   var x : int;
20
   let
21
   x = bar(in1, in2); -- a stateful node
22
   out1 = x;
23
   out2 = in2;
24
   tel
21 25

  
22
exception Unhandled of string
23
    
26
   Since foo contains a stateful node, it is stateful itself. Its prototype is 
27
   extended with a reset input. When the node is reset, each of its "pre" expression
28
   is reset as well as all calls to stateful node it contains. 
24 29

  
25
(* Basic printing functions *)
26
    
27
let pp_var_string fmt v = fprintf fmt "\"%s\"" v
28
(*let pp_var_name fmt v = fprintf fmt "\"%a\"" Printers.pp_var_name v*)
29
(*let pp_node_args = fprintf_list ~sep:", " pp_var_name*)
30

  
31
let pp_emf_var_decl fmt v =
32
  fprintf fmt "@[{\"name\": \"%a\", \"type\":\"%a\"}@]"
33
    Printers.pp_var_name v
34
    Printers.pp_var_type v
35
    
36
let pp_emf_vars_decl fmt vl =
37
  fprintf fmt "@[";
38
  fprintf_list ~sep:",@ " pp_emf_var_decl fmt vl;
39
  fprintf fmt "@]"
40
  
41
let reset_name id =
42
  "reset_" ^ id
43
  
44
    
45
(* Matlab starting counting from 1.
46
   simple function to extract the element id in the list. Starts from 1. *)
47
let rec get_idx x l =
48
  match l with
49
  | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
50
  | [] -> assert false
30
   will produce the following JSON struct:
31
   "foo": {"kind":  "stateful",
32
   inputs:  [{name: "in1", type: "int"}, 
33
   {name: "in2", type: "int"}, 
34
   ],
35
   outputs: [{name: "out1", type: "int"}, {name: "out2", type: "int"}],
36
   locals:  [{name: "x", type: "int"}],
37
   instrs:  {
38
   def_x: { lhs: ["x"], 
39
   rhs: {type: "statefulcall", name: "bar", 
40
   args: [in1, in2], reset: [ni4_reset] } 
41
   }
42
   
43
   def_out1: { lhs: "out1", rhs: "x" } ,
44
   def_out2: { lhs: "out2", rhs: "in2"}
45
   }
46
   }
51 47

  
52
(**********************************************)
53
(* Old stuff: printing normalized code as EMF *)     
54
(**********************************************)
48
   Basically we have the following different definitions
49
   1. local assign of a variable to another one:
50
   def_out1: { kind: "local_assign", lhs: "out1", rhs: "x" },
55 51

  
56
(*
57
let pp_expr vars fmt expr =
58
  let rec pp_expr fmt expr =
59
    match expr.expr_desc with
60
    | Expr_const c -> Printers.pp_const fmt c
61
    | Expr_ident id ->
62
       if List.mem id vars then
63
	 Format.fprintf fmt "u%i" (get_idx id vars)
64
       else
65
	 assert false (* impossible to find element id in var list *)
66
    | Expr_array a -> fprintf fmt "[%a]" pp_tuple a
67
    | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
68
    | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
69
    | Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
70
    | Expr_ite (c, t, e) -> fprintf fmt "if %a; y=(%a); else y=(%a); end" pp_expr c pp_expr t pp_expr e
71
    | Expr_arrow (e1, e2) ->(
72
      match e1.expr_desc, e2.expr_desc with
73
      | Expr_const c1, Expr_const c2 -> if c1 = Corelang.const_of_bool true && c2 = Corelang.const_of_bool false then fprintf fmt "STEP" else assert false (* only handle true -> false *)
74
      | _ -> assert false (* only handle true -> false *)
75
    )
76
    | Expr_fby (e1, e2) -> assert false (* not covered yet *)
77
    | Expr_pre e -> fprintf fmt "UNITDELAY"
78
    | Expr_when (e, id, l) -> assert false (* clocked based expressions are not handled yet *)
79
    | Expr_merge (id, hl) -> assert false (* clocked based expressions are not handled yet *)
80
    | Expr_appl (id, e, r) -> pp_app fmt id e r
81

  
82
  and pp_tuple fmt el =
83
    fprintf_list ~sep:"," pp_expr fmt el
84

  
85
  and pp_app fmt id e r =
86
    match r with
87
    | None -> pp_call fmt id e
88
    | Some c -> assert false (* clocked based expressions are not handled yet *)
89

  
90
  and pp_call fmt id e =
91
    match id, e.expr_desc with
92
    | "+", Expr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_expr e1 pp_expr e2
93
    | "uminus", _ -> fprintf fmt "(- %a)" pp_expr e
94
    | "-", Expr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_expr e1 pp_expr e2
95
    | "*", Expr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_expr e1 pp_expr e2
96
    | "/", Expr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_expr e1 pp_expr e2
97
    | "mod", Expr_tuple([e1;e2]) -> fprintf fmt "mod (%a, %a)" pp_expr e1 pp_expr e2
98
    | "&&", Expr_tuple([e1;e2]) -> fprintf fmt "(%a & %a)" pp_expr e1 pp_expr e2
99
    | "||", Expr_tuple([e1;e2]) -> fprintf fmt "(%a | %a)" pp_expr e1 pp_expr e2
100
    | "xor", Expr_tuple([e1;e2]) -> fprintf fmt "xor (%a, %a)" pp_expr e1 pp_expr e2
101
    | "impl", Expr_tuple([e1;e2]) -> fprintf fmt "((~%a) | %a)" pp_expr e1 pp_expr e2
102
    | "<", Expr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_expr e1 pp_expr e2
103
    | "<=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_expr e1 pp_expr e2
104
    | ">", Expr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_expr e1 pp_expr e2
105
    | ">=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_expr e1 pp_expr e2
106
    | "!=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a ~= %a)" pp_expr e1 pp_expr e2
107
    | "=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a == %a)" pp_expr e1 pp_expr e2
108
    | "not", _ -> fprintf fmt "(~%a)" pp_expr e
109
    | _, Expr_tuple _ -> fprintf fmt "%s %a" id pp_expr e
110
    | _ -> fprintf fmt "%s (%a)" id pp_expr e
52
   2. pre construct over a variable (this is a state assign):
53
   def_pre_x: { kind: "pre", lhs: "pre_x", rhs: "x" },
54

  
55
   3. arrow constructs, while there is not specific input, it could be reset 
56
   by a specific signal. We register it as a fresh rhs var:
57
   def_arrow: { kind: "arrow", name: "ni4", lhs: "is_init", rhs: "reset_ni4"}
58

  
59
   2. call to a stateless function, typically an operator
60
   def_x: { kind: "statelesscall", lhs: ["x"], 
61
   name: "bar", rhs: [in1, in2]} 
62
   
63
   or in the operator version 
64
   def_x: { kind: "operator", lhs: ["x"], 
65
   name: "+", rhs: [in1, in2]} 
66
   
67

  
68
   In Simulink this should introduce a subsystem in the first case or a 
69
   regular block in the second with card(lhs) outputs and card{args} inputs.
70

  
71
   3. call to a stateful node. It is similar to the stateless above, 
72
   with the addition of the reset argument
73
   { def_x: { kind: "statefulcall", lhs: ["x"], 
74
   name: "bar", rhs: [in1, in2], reset: [ni4_reset] } 
75
   }
76
   
77
   In lustrec compilation phases, a unique id is associated to this specific
78
   instance of stateful node "bar", here ni4. 
79
   Instruction such as reset(ni4) or noreset(ni4) may -- or not -- reset this 
80
   specific node. This corresponds to "every c" suffix of a node call in lustre.
81

  
82
   In Simulink this should introduce a subsystem that has this extra reset input.  
83
   The reset should be defined as an "OR" over (1) the input reset of the parent 
84
   node, __reset in the present example and (2) any occurence of reset(ni4) in 
85
   the instructions.
86

  
87
   4. branching construct: (guard expr, (tag, instr list) list)
88
   "merge_XX": { type: "branch", guard: "var_guard", 
89
   inputs:   ["varx", "vary"],
90
   outputs:  ["vark", "varz"],
91
   branches: {"tag1": {liste_of_definitions (1-4)}, ...}
92
   }
93
   
94

  
95
   In Simulink, this should become one IF block to produce enable ports 
96
   "var_guard == tag1", "var_guard == tag2", .... as well as one action 
97
   block per branch: each of these action block shall  
111 98

  
112
  in
113
  pp_expr fmt expr
114

  
115
let pp_stmt fmt stmt =
116
  match stmt with
117
  | Eq eq -> (
118
    match eq.eq_lhs with
119
      [var] -> (
120
     (* first, we extract the expression and associated variables *)
121
	let vars = Utils.ISet.elements (Corelang.get_expr_vars eq.eq_rhs) in
122

  
123
	fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\",@ \"vars\": [%a] @]}"
124
	  var
125
	  (pp_expr vars) eq.eq_rhs (* todo_pp_expr expr *)
126
	  (fprintf_list ~sep:", " pp_var_string) vars
127
      )
128
    | _ -> assert false (* should not happen for input of EMF backend (cocospec generated nodes *)
129
  )
130
  | _ -> assert false (* should not happen with EMF backend *)
131

  
132
let pp_node fmt nd =
133
  fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a],@ \"outputs\": [%a],@ "
134
    nd.node_id
135
    pp_node_args nd.node_inputs
136
    pp_node_args nd.node_outputs;
137
  fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"
138
    (fprintf_list ~sep:",@ " pp_stmt ) nd.node_stmts;
139
  fprintf fmt "@]@ }"
140

  
141
let pp_decl fmt decl =
142
  match decl.top_decl_desc with
143
  | Node nd -> fprintf fmt "%a@ " pp_node nd
144
  | ImportedNode _
145
  | Const _
146
  | Open _
147
  | TypeDef _ -> eprintf "should not happen in EMF backend"
148 99
*)
149 100

  
101
open LustreSpec
102
open Machine_code
103
open Format 
104
open EMF_common
105
exception Unhandled of string
106

  
107
module ISet = Utils.ISet
108
let fprintf_list = Utils.fprintf_list
109
  
110

  
150 111

  
151 112
(**********************************************)
152 113
(*   Utility functions: arrow and lustre expr *)
......
156 117
   -> false *)
157 118
let is_arrow_fun m i =
158 119
  match Corelang.get_instr_desc i with
159
  | MStep ([var], i, vl)  -> (
160
    let name = try (Machine_code.get_node_def i m).node_id with Not_found -> Format.eprintf "Impossible to find node %s@.@?" i; raise Not_found in
161
    match name, vl with
162
    | "_arrow", [v1; v2] -> (
120
  | MStep ([var], i, vl) -> (
121
    try
122
      let name = (Machine_code.get_node_def i m).node_id in
123
      match name, vl with
124
      | "_arrow", [v1; v2] -> (
163 125
	match v1.value_desc, v2.value_desc with
164 126
	| Cst c1, Cst c2 ->
165 127
	   if c1 = Corelang.const_of_bool true && c2 = Corelang.const_of_bool false then
......
167 129
	   else
168 130
	     assert false (* only handle true -> false *)
169 131
	| _ -> assert false
170
    )
171
    | _ -> false
132
      )
133
	 
134
      | _ -> false
135
    with
136
    | Not_found -> false (* Not declared (should have been detected now, or imported node *)
172 137
  )
173 138
  | _ -> false
174 139

  
175
let pp_original_lustre_expression m fmt i =
176
  match Corelang.get_instr_desc i with
177
  | MLocalAssign _ | MStateAssign _ 
178
  | MBranch _
179
    -> ( match i.lustre_eq with None -> () | Some e -> Printers.pp_node_eq fmt e) 
180
  | MStep _ when is_arrow_fun m i -> () (* we print nothing, this is a STEP *)
181
  | MStep _ -> (match i.lustre_eq with None -> () | Some eq -> Printers.pp_node_eq fmt eq)
182
  | _ -> ()
183

  
184
     (*
185
let rec get_instr_lhs i =
186
  match Corelang.get_instr_desc i with
187
  | MLocalAssign (var,_) 
188
  | MStateAssign (var,_) -> [var.var_id]
189
  | MStep (vars, _, _)  ->  List.map (fun v -> v.var_id) vars
190
  | MBranch (_,(_,case1)::_)     ->
191
     get_instrs_lhs case1 (* assuming all cases define the same variables *)
192
  | MBranch _ -> assert false (* branch instruction should admit at least one case *)
193
  | MReset ni           
194
  | MNoReset ni -> [reset_name ni]
195
  | MComment _ -> assert false (* not  available for EMF output *)
196
and get_instrs_lhs il =
197
  List.fold_left (fun accu i -> (get_instr_lhs i) @ accu ) [] il
198
  *)     
199 140
(**********************************************)
200 141
(*   Printing machine code as EMF             *)
201 142
(**********************************************)
202 143

  
203
(*******************
204 144
     
205
(* Print machine code values as matlab expressions. Variable identifiers are
206
   replaced by uX where X is the index of the variables in the list vars of input
207
   variables. *)
208
let rec pp_matlab_val vars fmt v =
209
  match v.value_desc with
210
  | Cst c -> Printers.pp_const fmt c
211
  | LocalVar v
212
  | StateVar v ->
213
     let id = v.var_id in
214
     if List.mem id vars then
215
       Format.fprintf fmt "u%i" (get_idx id vars)
216
     else
217
       let _ = Format.eprintf "Error: looking for var %s in %a@.@?" id (Utils.fprintf_list ~sep:"," Format.pp_print_string) vars in assert false (* impossible to find element id in var list *)
218
  | Fun (n, vl) -> pp_fun vars n fmt vl
219
  | _ -> assert false (* not available in EMF backend *)
220
and pp_fun vars id fmt vl =
221
  (* eprintf "print %s with %i args@.@?" id (List.length vl);*)
222
  match id, vl with
223
    | "+", [v1;v2] -> fprintf fmt "(%a + %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
224
    | "uminus", [v] -> fprintf fmt "(- %a)" (pp_matlab_val vars) v
225
    | "-", [v1;v2] -> fprintf fmt "(%a - %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
226
    | "*",[v1;v2] -> fprintf fmt "(%a * %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
227
    | "/", [v1;v2] -> fprintf fmt "(%a / %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
228
    | "mod", [v1;v2] -> fprintf fmt "mod (%a, %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
229
    | "&&", [v1;v2] -> fprintf fmt "(%a & %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
230
    | "||", [v1; v2] -> fprintf fmt "(%a | %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
231
    | "xor", [v1; v2] -> fprintf fmt "xor (%a, %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
232
    | "impl", [v1; v2] -> fprintf fmt "((~%a) | %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
233
    | "<", [v1; v2] -> fprintf fmt "(%a < %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
234
    | "<=", [v1; v2] -> fprintf fmt "(%a <= %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
235
    | ">", [v1; v2] -> fprintf fmt "(%a > %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
236
    | ">=", [v1; v2] -> fprintf fmt "(%a >= %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
237
    | "!=", [v1; v2] -> fprintf fmt "(%a != %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
238
    | "=", [v1; v2] -> fprintf fmt "(%a = %a)" (pp_matlab_val vars) v1 (pp_matlab_val vars) v2
239
    | "not", [v] -> fprintf fmt "(~%a)" (pp_matlab_val vars) v
240
    | _ -> fprintf fmt "%s (%a)" id  (Utils.fprintf_list ~sep:", " (pp_matlab_val vars)) vl 
241

  
242
     
243

  
244
(* pp_basic_instr prints regular instruction. These do not contain MStep which
245
   should have been already filtered out. Another restriction which is supposed
246
   to be enforced is that branching statement contain a single instruction (in
247
   practice it has to be an assign) *)
248
let pp_matlab_basic_instr m vars fmt i =
249
  match Corelang.get_instr_desc i with
250
  | MLocalAssign (var,v) 
251
  | MStateAssign (var,v) -> fprintf fmt "y = %a" (pp_matlab_val vars) v
252
  | MReset _           
253
    -> Format.eprintf "unhandled reset in EMF@.@?"; assert false
254
  | MNoReset _
255
    -> Format.eprintf "unhandled noreset in EMF@.@?"; assert false
256
  | MBranch _ (* branching instructions already handled *)
257
    -> Format.eprintf "unhandled branch statement in EMF (should have been filtered out before)@.@?";
258
      assert false
259
  | MStep _ (* function calls already handled, including STEP *)
260
    -> Format.eprintf "unhandled function call in EMF (should have been filtered out before)@.@?";
261
      assert false
262
  | MComment _ 
263
    -> Format.eprintf "unhandled comment in EMF@.@?"; assert false
264
      (* not  available for EMF output *)
265

  
266

  
267

  
268
let rec get_instr_lhs_var i =
269
  match Corelang.get_instr_desc i with
270
  | MLocalAssign (var,_) 
271
  | MStateAssign (var,_) 
272
  | MStep ([var], _, _)  ->
273
     (* The only MStep instructions that filtered here
274
	should be arrows, ie. single var *)
275
     var
276
  | MBranch (_,(_,case1)::_)     ->
277
     get_instrs_var case1 (* assuming all cases define the same variables *)
278
  | MStep (f,name,a) -> Format.eprintf "step %s@.@?" name; assert false (* no other MStep here *)
279
  | MBranch _ -> assert false (* branch instruction should admit at least one case *)
280
  | MReset _           
281
  | MNoReset _
282
  | MComment _ -> assert false (* not  available for EMF output *)
283
and get_instrs_var il =
284
  match il with
285
  | i::_ -> get_instr_lhs_var i (* looking for the first instr *)
286
  | _ -> assert false
287

  
288
  
289
let rec  get_val_vars v =
290
  match v.value_desc with
291
  | Cst c -> Utils.ISet.empty
292
  | LocalVar v
293
  | StateVar v -> Utils.ISet.singleton v.var_id
294
  | Fun (n, vl) -> List.fold_left (fun res v -> Utils.ISet.union (get_val_vars v) res) Utils.ISet.empty vl
295
  | _ -> assert false (* not available in EMF backend *)
296

  
297
let rec get_instr_rhs_vars i =
298
  match Corelang.get_instr_desc i with
299
  | MLocalAssign (_,v)  
300
  | MStateAssign (_,v) -> get_val_vars v
301
  | MStep (_, _, vl)  -> List.fold_left (fun res v -> Utils.ISet.union res (get_val_vars v)) Utils.ISet.empty vl 
302
  | MBranch (c,[(_,[case1]);(_,[case2])])     ->
303
     Utils.ISet.union
304
       (get_val_vars c)
305
       (
306
	 Utils.ISet.union
307
	   (get_instr_rhs_vars case1)
308
	   (get_instr_rhs_vars case2)
309
       )
310
  | MBranch (g, branches) ->
311
     List.fold_left
312
       (fun accu (_, il) -> Utils.ISet.union accu (get_instrs_vars il))
313
       (get_val_vars g)
314
       branches
315
  | MReset id           
316
  | MNoReset id -> Utils.ISet.singleton id
317
  | MComment _ -> Utils.ISet.empty
318
and get_instrs_vars il =
319
  List.fold_left (fun res i -> Utils.ISet.union res (get_instr_rhs_vars i))
320
    Utils.ISet.empty
321
    il
322

  
323

  
324
     
325
let rec pp_emf_instr m fmt i =
326
  (* Either it is a Step function non arrow, then we have a dedicated treatment,
327
     or it has to be a single variable assigment *)
328
  let arguments_vars = Utils.ISet.elements (get_instr_rhs_vars i) in	
329
  
330
  match Corelang.get_instr_desc i with
331
  (* Regular node call either a statuful node or a functional one *)
332
  | MStep (outputs, f, inputs) when not (is_arrow_fun m i) -> (
333
    fprintf fmt "\"CALL\": @[<v 2>{ \"node\": \"%s\",@ \"inputs\": [%a],@ \"vars\": [%a]@ \"lhs\": [%a],@ \"original_lustre_expr\": [%a]@]}"
334
      ((Machine_code.get_node_def f m).node_id) (* Node name *)
335
      (Utils.fprintf_list ~sep:", " (fun fmt _val -> fprintf fmt "\"%a\"" (pp_matlab_val arguments_vars) _val)) inputs                  (* inputs *)
336
      (fprintf_list ~sep:", " pp_var_string) arguments_vars
337
      (fprintf_list ~sep:", " (fun fmt v -> pp_var_string fmt v.var_id)) outputs  (* outputs *)
338
      (pp_original_lustre_expression m) i         (* original lustre expr *)
339
  )
340
  | MStep _ -> (* Arrow case *) (
341
    let var = get_instr_lhs_var i in
342
    fprintf fmt "\"STEP\": @[<v 2>{ \"lhs\": \"%s\",@ \"vars\": [%a] @ \"original_lustre_expr\": [%a]@]}"
343
      var.var_id
344
      (fprintf_list ~sep:", " pp_var_string) arguments_vars
345
      (pp_original_lustre_expression m) i
346
  )
347
  | MBranch (g,[(tag1,[case1]);(tag2,[case2])]) when tag1 = Corelang.tag_true || tag2 = Corelang.tag_true  ->
348
     (* Thanks to normalization with join_guards = false, branches shall contain
349
	a single expression *)
350
     let var = get_instr_lhs_var i in
351
     let then_case, else_case =
352
       if tag1 = Corelang.tag_true then
353
	 case1, case2
354
       else
355
	 case2, case1
356
     in
357
     fprintf fmt "\"ITE\": @[<v 2>{ \"lhs\": \"%s\",@ \"guard\": \"%a\",@ \"then_expr\": \"%a\",@ \"else_expr\": \"%a\",@ \"vars\": [%a],@ \"original_lustre_expr\": [%a]@]}"
358
       var.var_id
359
       (pp_matlab_val arguments_vars) g
360
       (pp_matlab_basic_instr m arguments_vars) then_case
361
       (pp_matlab_basic_instr m arguments_vars) else_case
362
       (fprintf_list ~sep:", " pp_var_string) arguments_vars
363
       (pp_original_lustre_expression m) i
364

  
365
  | MBranch (g, [single_tag, single_branch]) ->
366
     (* First case: it corresponds to a clocked expression: a MBranch with a
367
	single case. It shall become a subsystem with an enable port that depends on g = single_tag *)
368
     (* Thanks to normalization with join_guards = false, branches shall contain
369
	a single expression TODO REMOVE COMMENT THIS IS NOT TRUE *)
370
     let var = get_instr_lhs_var i in
371
     fprintf fmt "\"ENABLEDSUB\": @[<v 2>{ \"lhs\": \"%s\",@ \"enable_cond\": \"%a = %s\",@ \"subsystem\": {%a },@ \"vars\": [%a],@ \"original_lustre_expr\": [%a]@]}"
372
       var.var_id
373
       (pp_matlab_val arguments_vars) g
374
       single_tag
375
       (fprintf_list ~sep:",@ " (pp_emf_instr m)) single_branch
376
       (fprintf_list ~sep:", " pp_var_string) arguments_vars
377
       (pp_original_lustre_expression m) i
378
       
379
  | MBranch (g, hl) ->
380
     (* Thanks to normalization with join_guards = false, branches shall contain
381
	a single expression *)
382
     fprintf fmt "\"BRANCH\": @[<v 2>{ \"guard\": \"%a\",@ \"branches\": [@[<v 0>%a@]],@ \"vars\": [%a],@ \"original_lustre_expr\": [%a]@]}"
383
       (pp_matlab_val arguments_vars) g
384
       (fprintf_list ~sep:",@ "
385
	  (fun fmt (tag, (is_tag: instr_t list)) ->
386
	    fprintf fmt "\"%s\": [%a]"
387
	      tag
388
	      (fprintf_list ~sep:",@ " (fun fmt i_tag -> match Corelang.get_instr_desc i_tag with
389
		  | MLocalAssign (var,v) 
390
		  | MStateAssign (var,v) ->
391
		     fprintf fmt "{lhs= \"%s\", rhs= \"%a\"]" var.var_id (pp_matlab_val arguments_vars) v
392
		  | _ -> Format.eprintf "unhandled instr: %a@." Machine_code.pp_instr i_tag; assert false
393
	      )) is_tag
394
	  )) hl 
395
       (fprintf_list ~sep:", " pp_var_string) arguments_vars
396
       (pp_original_lustre_expression m) i
397
       
398
       
399
       
400
  | _ ->
401
     (* Other expressions, including "pre" *)
402
     ( 
403
       (* first, we extract the expression and associated variables *)
404
       let var = get_instr_lhs_var i in
405
       fprintf fmt "\"EXPR\": @[<v 2>{ \"lhs\": \"%s\",@ \"expr\": \"%a\",@ \"vars\": [%a] @ \"original_lustre_expr\": [%a]@]}"
406
	 var.var_id
407
	 (fun fmt i -> match Corelang.get_instr_desc i with
408
	 | MStep _ -> fprintf fmt "STEP"
409
	 | _ -> pp_matlab_basic_instr m arguments_vars fmt i) i
410
	 (fprintf_list ~sep:", " pp_var_string) arguments_vars
411
	 (pp_original_lustre_expression m) i
412
     )
413

  
414
*********************)
415
     
416
let pp_emf_cst_or_var fmt v =
417
  match v.value_desc with
418
  | Cst c ->
419
     fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\"@ @]}"
420
       Printers.pp_const c
421
  | LocalVar v
422
  | StateVar v ->
423
     fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\"@ @]}"
424
       Printers.pp_var_name v
425
  | _ -> assert false (* Invalid argument *)
426

  
427
let rec get_expr_vars v =
428
  match v.value_desc with
429
  | Cst c -> VSet.empty
430
  | LocalVar v | StateVar v -> VSet.singleton v
431
  | Fun (_, args) -> List.fold_left (fun accu v -> VSet.union accu (get_expr_vars v)) VSet.empty args
432
  | _ -> assert false (* Invalid argument *)
433 145

  
434 146
let branch_cpt = ref 0
435 147
let get_instr_id fmt i =
......
437 149
  | MLocalAssign(lhs,_) | MStateAssign (lhs, _) -> Printers.pp_var_name fmt lhs
438 150
  | MReset i | MNoReset i -> fprintf fmt "%s" (reset_name i)
439 151
  | MBranch (g, _) -> incr branch_cpt; fprintf fmt "branch_%i" !branch_cpt
440
  | MStep (_, id, _) -> fprintf fmt "%s" id
152
  | MStep (outs, id, _) -> fprintf fmt "%a_%s" (fprintf_list ~sep:"_" Printers.pp_var_name) outs id
441 153
  | _ -> () (* No name *)
442 154

  
443 155
let rec branch_block_vars il =
......
474 186
  | MComment _ -> assert false (* not  available for EMF output *)
475 187
     
476 188
  
477
let pp_emf_cst_or_var_list =
478
  fprintf_list ~sep:",@ " pp_emf_cst_or_var
479
    
480
let rec pp_emf_instr2 m fmt i =
481
  (* let arguments_vars = Utils.ISet.elements (get_instr_rhs_vars i) in	   *)
189
      
190
let rec pp_emf_instr m fmt i =
482 191
  let pp_content fmt i =
483 192
    match Corelang.get_instr_desc i with
484 193
    | MLocalAssign(lhs, expr)
......
529 238
    fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl
530 239
      (* (let guard_inputs = get_expr_vars g in
531 240
	  VSet.elements (VSet.diff inputs guard_inputs)) -- previous version to
532
	 removed guard's variable from inputs *)
241
	 remove guard's variable from inputs *)
533 242
      (VSet.elements inputs)
534 243
    ;
535 244
    fprintf fmt "@[<v 2>\"branches\": {@ %a@]}@ "
536 245
      (fprintf_list ~sep:",@ "
537 246
	 (fun fmt (tag, instrs_tag) ->
538
	   let (*branch_outputs*) _, branch_inputs = branch_block_vars instrs_tag in
539
    	   
247
	   let (*branch_outputs*) _, branch_inputs = branch_block_vars instrs_tag in    	   
540 248
	   fprintf fmt "@[<v 2>\"%s\": {@ " tag;
541 249
	   fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl (VSet.elements branch_inputs); 
542 250
	   fprintf fmt "@[<v 2>\"instrs\": {@ ";
543
	   fprintf_list ~sep:",@ " (pp_emf_instr2 m) fmt instrs_tag;
251
	   fprintf_list ~sep:",@ " (pp_emf_instr m) fmt instrs_tag;
544 252
	   fprintf fmt "@]}@ ";
545 253
	   fprintf fmt "@]}"
546 254

  
......
556 264
      (reset_name f)
557 265
  )
558 266

  
559
  | MStep (outputs, f, inputs) -> (
267
  | MStep (outputs, f, inputs) when not (is_imported_node f m) -> (
560 268
    let node_f = Machine_code.get_node_def f m in
561 269
    let is_stateful = List.mem_assoc f m.minstances in 
562 270
    fprintf fmt "\"kind\": \"%s\",@ \"name\": \"%s\",@ \"id\": \"%s\",@ "
......
569 277
    if is_stateful then fprintf fmt ",@ \"reset\": \"%s\"" (reset_name f) else fprintf fmt "@ "
570 278
  )
571 279

  
280
  | MStep(outputs, f, inputs ) -> (* This is an imported node *)
281
        EMF_library_calls.pp_call fmt m f outputs inputs
282
	  
572 283
  | MComment _ 
573 284
    -> Format.eprintf "unhandled comment in EMF@.@?"; assert false
574 285
  (* not  available for EMF output *)
......
576 287
  in
577 288
  fprintf fmt "@[ @[<v 2>\"%a\": {@ " get_instr_id i;
578 289
  fprintf fmt "%a@ " pp_content i;
579
  (* fprintf fmt "@[<v 2>\"original_lustre_expr\": [@ \"%a\"@]]@]" (pp_original_lustre_expression m) i;  *)
580 290
  fprintf fmt "}@]"
581 291

  
582 292
       
583
       
584
(* A (normalized) node becomes a JSON struct
585
   node foo (in1, in2: int) returns (out1, out2: int);
586
   var x : int;
587
   let
588
     x = bar(in1, in2); -- a stateful node
589
     out1 = x;
590
     out2 = in2;
591
   tel
592

  
593
   Since foo contains a stateful node, it is stateful itself. Its prototype is 
594
   extended with a reset input. When the node is reset, each of its "pre" expression
595
   is reset as well as all calls to stateful node it contains. 
596

  
597
   will produce the following JSON struct:
598
   "foo": {"kind":  "stateful",
599
           inputs:  [{name: "in1", type: "int"}, 
600
                     {name: "in2", type: "int"}, 
601
                    ],
602
           outputs: [{name: "out1", type: "int"}, {name: "out2", type: "int"}],
603
           locals:  [{name: "x", type: "int"}],
604
           instrs:  {
605
                    def_x: { lhs: ["x"], 
606
                               rhs: {type: "statefulcall", name: "bar", 
607
                                     args: [in1, in2], reset: [ni4_reset] } 
608
                             }
609
                    
610
                    def_out1: { lhs: "out1", rhs: "x" } ,
611
                    def_out2: { lhs: "out2", rhs: "in2"}
612
                    }
613
           }
614

  
615
Basically we have the following different definitions
616
1. local assign of a variable to another one:
617
   def_out1: { kind: "local_assign", lhs: "out1", rhs: "x" },
618

  
619
2. pre construct over a variable (this is a state assign):
620
   def_pre_x: { kind: "pre", lhs: "pre_x", rhs: "x" },
621

  
622
3. arrow constructs, while there is not specific input, it could be reset 
623
   by a specific signal. We register it as a fresh rhs var:
624
   def_arrow: { kind: "arrow", name: "ni4", lhs: "is_init", rhs: "reset_ni4"}
625

  
626
2. call to a stateless function, typically an operator
627
    def_x: { kind: "statelesscall", lhs: ["x"], 
628
              name: "bar", rhs: [in1, in2]} 
629
   
630
  or in the operator version 
631
   def_x: { kind: "operator", lhs: ["x"], 
632
              name: "+", rhs: [in1, in2]} 
633
   
634

  
635
  In Simulink this should introduce a subsystem in the first case or a 
636
  regular block in the second with card(lhs) outputs and card{args} inputs.
637

  
638
3. call to a stateful node. It is similar to the stateless above, 
639
   with the addition of the reset argument
640
    { def_x: { kind: "statefulcall", lhs: ["x"], 
641
               name: "bar", rhs: [in1, in2], reset: [ni4_reset] } 
642
      }
643
  
644
  In lustrec compilation phases, a unique id is associated to this specific
645
  instance of stateful node "bar", here ni4. 
646
  Instruction such as reset(ni4) or noreset(ni4) may -- or not -- reset this 
647
  specific node. This corresponds to "every c" suffix of a node call in lustre.
648

  
649
  In Simulink this should introduce a subsystem that has this extra reset input.  
650
  The reset should be defined as an "OR" over (1) the input reset of the parent 
651
  node, __reset in the present example and (2) any occurence of reset(ni4) in 
652
  the instructions.
653

  
654
4. branching construct: (guard expr, (tag, instr list) list)
655
    "merge_XX": { type: "branch", guard: "var_guard", 
656
                   inputs:   ["varx", "vary"],
657
                   outputs:  ["vark", "varz"],
658
                   branches: {"tag1": {liste_of_definitions (1-4)}, ...}
659
                 }
660
   
661

  
662
  In Simulink, this should become one IF block to produce enable ports 
663
  "var_guard == tag1", "var_guard == tag2", .... as well as one action 
664
  block per branch: each of these action block shall  
665
*)     
666 293
let pp_machine fmt m =
667 294
  try
668 295
    fprintf fmt "@[<v 2>\"%s\": {@ "
......
676 303
      pp_emf_vars_decl m.mstep.step_locals
677 304
    ;
678 305
    fprintf fmt "\"instrs\": {@[<v 0> %a@]@ }"
679
      (fprintf_list ~sep:",@ " (pp_emf_instr2 m)) m.mstep.step_instrs;
306
      (fprintf_list ~sep:",@ " (pp_emf_instr m)) m.mstep.step_instrs;
680 307
    fprintf fmt "@]@ }"
681 308
  with Unhandled msg -> (
682 309
    eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
src/backends/EMF/EMF_common.ml
1
open LustreSpec
2
open Format
3
open Machine_code 
4

  
5
(* Matlab starting counting from 1.
6
   simple function to extract the element id in the list. Starts from 1. *)
7
let rec get_idx x l =
8
  match l with
9
  | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
10
  | [] -> assert false
11

  
12
let rec get_expr_vars v =
13
  match v.value_desc with
14
  | Cst c -> VSet.empty
15
  | LocalVar v | StateVar v -> VSet.singleton v
16
  | Fun (_, args) -> List.fold_left (fun accu v -> VSet.union accu (get_expr_vars v)) VSet.empty args
17
  | _ -> assert false (* Invalid argument *)
18

  
19
let is_imported_node f m =
20
  let (decl, _) = List.assoc f m.mcalls in
21
  Corelang.is_imported_node decl
22
    
23
(* Basic printing functions *)
24
    
25
let pp_var_string fmt v = fprintf fmt "\"%s\"" v
26
(*let pp_var_name fmt v = fprintf fmt "\"%a\"" Printers.pp_var_name v*)
27
(*let pp_node_args = fprintf_list ~sep:", " pp_var_name*)
28

  
29
let pp_emf_var_decl fmt v =
30
  fprintf fmt "@[{\"name\": \"%a\", \"type\":\"%a\"}@]"
31
    Printers.pp_var_name v
32
    Printers.pp_var_type v
33
    
34
let pp_emf_vars_decl fmt vl =
35
  fprintf fmt "@[";
36
  Utils.fprintf_list ~sep:",@ " pp_emf_var_decl fmt vl;
37
  fprintf fmt "@]"
38
  
39
let reset_name id =
40
  "reset_" ^ id
41
  
42
    
43
let pp_emf_cst_or_var fmt v =
44
  match v.value_desc with
45
  | Cst c ->
46
     fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\"@ @]}"
47
       Printers.pp_const c
48
  | LocalVar v
49
  | StateVar v ->
50
     fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\"@ @]}"
51
       Printers.pp_var_name v
52
  | _ -> assert false (* Invalid argument *)
53

  
54

  
55
let pp_emf_cst_or_var_list =
56
  Utils.fprintf_list ~sep:",@ " pp_emf_cst_or_var
57

  
58

  
59
(* Local Variables: *)
60
(* compile-command: "make -C ../.." *)
61
(* End: *)
src/backends/EMF/EMF_library_calls.ml
1
(** This function focuses on standard library calls: conversion functions and
2
    math library. It could be later extended to handle more functions. For the
3
    moment, modular compilation of multiple lustre sources as one output JSON is not
4
    considered. *)
5

  
6
open LustreSpec
7
open Machine_code
8
open Format
9
open EMF_common
10

  
11
let pp_call fmt m f outputs inputs =
12
  let (decl, _) = List.assoc f m.mcalls in
13
  if Corelang.is_imported_node decl then
14
    let inode = Corelang.imported_node_of_top decl in
15
    match inode.nodei_id, Filename.basename decl.top_decl_owner with
16
    | name, (("math" | "conv") as lib) -> (
17
      fprintf fmt "\"kind\": \"functioncall\",@ \"name\": \"%s\",@ \"library\": \"%s\",@ "
18
        name lib;
19
      fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
20
	(Utils.fprintf_list ~sep:",@ " (fun fmt v -> fprintf fmt "\"%a\"" Printers.pp_var_name v)) outputs
21
	pp_emf_cst_or_var_list inputs
22
    )
23
    | _ ->
24
       Format.eprintf "Calls to function %s in library %s are not handled yet.@."
25
      	 inode.nodei_id
26
      	 (Filename.basename decl.top_decl_owner)
27
      ;
28
      assert false
29
  else
30
    assert false (* shall not happen *)
31

  
32

  
33

  
34
  
35
  (* Local Variables: *)
36
  (* compile-command: "make -C ../.." *)
37
  (* End: *)
38
  
src/corelang.ml
109 109
let node_of_top top_decl =
110 110
  match top_decl.top_decl_desc with
111 111
  | Node nd -> nd
112
  | _ -> assert false
112
  | _ -> raise Not_found
113 113

  
114 114
let imported_node_of_top top_decl =
115 115
  match top_decl.top_decl_desc with
src/machine_code.ml
106 106
  try
107 107
    let (decl, _) = List.assoc id m.mcalls in
108 108
    Corelang.node_of_top decl
109
  with Not_found -> (
110
    Format.eprintf "Unable to find node %s in list [%a]@.@?"
111
      id
112
      (Utils.fprintf_list ~sep:", " (fun fmt (n,_) -> Format.fprintf fmt "%s" n)) m.mcalls
113
    ;
109
  with Not_found -> ( 
110
    (* Format.eprintf "Unable to find node %s in list [%a]@.@?" *)
111
    (*   id *)
112
    (*   (Utils.fprintf_list ~sep:", " (fun fmt (n,_) -> Format.fprintf fmt "%s" n)) m.mcalls *)
113
    (* ; *)
114 114
    raise Not_found
115 115
  )
116 116
    

Also available in: Unified diff