Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / EMF / EMF_backend.ml @ f7caf067

History | View | Annotate | Download (10.3 KB)

1
open LustreSpec
2
open Machine_code
3
open Format
4
open Utils
5

    
6
exception Unhandled of string
7
  
8
let pp_var_string fmt v = fprintf fmt "\"%s\"" v
9
let pp_var_name fmt v = fprintf fmt "\"%a\"" Printers.pp_var_name v
10

    
11
let pp_node_args = fprintf_list ~sep:", " pp_var_name
12

    
13
(* simple function to extract the element id in the list. Starts from 1. *)
14
let rec get_idx x l =
15
  match l with
16
  | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
17
  | [] -> assert false
18
     
19
let pp_expr vars fmt expr =
20
  let rec pp_expr fmt expr =
21
    match expr.expr_desc with
22
    | Expr_const c -> Printers.pp_const fmt c
23
    | Expr_ident id ->
24
       if List.mem id vars then
25
	 Format.fprintf fmt "u(%i)" (get_idx id vars)
26
       else
27
	 assert false (* impossible to find element id in var list *)
28
    | Expr_array a -> fprintf fmt "[%a]" pp_tuple a
29
    | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
30
    | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
31
    | Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
32
    | Expr_ite (c, t, e) -> fprintf fmt "if %a; y=(%a); else y=(%a); end" pp_expr c pp_expr t pp_expr e
33
    | Expr_arrow (e1, e2) ->(
34
      match e1.expr_desc, e2.expr_desc with
35
      | 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 *)
36
      | _ -> assert false (* only handle true -> false *)
37
    )
38
    | Expr_fby (e1, e2) -> assert false (* not covered yet *)
39
    | Expr_pre e -> fprintf fmt "UNITDELAY"
40
    | Expr_when (e, id, l) -> assert false (* clocked based expressions are not handled yet *)
41
    | Expr_merge (id, hl) -> assert false (* clocked based expressions are not handled yet *)
42
    | Expr_appl (id, e, r) -> pp_app fmt id e r
43

    
44
  and pp_tuple fmt el =
45
    fprintf_list ~sep:"," pp_expr fmt el
46

    
47
  and pp_app fmt id e r =
48
    match r with
49
    | None -> pp_call fmt id e
50
    | Some c -> assert false (* clocked based expressions are not handled yet *)
51

    
52
  and pp_call fmt id e =
53
    match id, e.expr_desc with
54
    | "+", Expr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_expr e1 pp_expr e2
55
    | "uminus", _ -> fprintf fmt "(- %a)" pp_expr e
56
    | "-", Expr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_expr e1 pp_expr e2
57
    | "*", Expr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_expr e1 pp_expr e2
58
    | "/", Expr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_expr e1 pp_expr e2
59
    | "mod", Expr_tuple([e1;e2]) -> fprintf fmt "mod (%a, %a)" pp_expr e1 pp_expr e2
60
    | "&&", Expr_tuple([e1;e2]) -> fprintf fmt "(%a & %a)" pp_expr e1 pp_expr e2
61
    | "||", Expr_tuple([e1;e2]) -> fprintf fmt "(%a | %a)" pp_expr e1 pp_expr e2
62
    | "xor", Expr_tuple([e1;e2]) -> fprintf fmt "xor (%a, %a)" pp_expr e1 pp_expr e2
63
    | "impl", Expr_tuple([e1;e2]) -> fprintf fmt "((~%a) | %a)" pp_expr e1 pp_expr e2
64
    | "<", Expr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_expr e1 pp_expr e2
65
    | "<=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_expr e1 pp_expr e2
66
    | ">", Expr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_expr e1 pp_expr e2
67
    | ">=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_expr e1 pp_expr e2
68
    | "!=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a ~= %a)" pp_expr e1 pp_expr e2
69
    | "=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a == %a)" pp_expr e1 pp_expr e2
70
    | "not", _ -> fprintf fmt "(~%a)" pp_expr e
71
    | _, Expr_tuple _ -> fprintf fmt "%s %a" id pp_expr e
72
    | _ -> fprintf fmt "%s (%a)" id pp_expr e
73

    
74
  in
75
  pp_expr fmt expr
76

    
77
let pp_stmt fmt stmt =
78
  match stmt with
79
  | Eq eq -> (
80
    match eq.eq_lhs with
81
      [var] -> (
82
     (* first, we extract the expression and associated variables *)
83
	let vars = Utils.ISet.elements (Corelang.get_expr_vars eq.eq_rhs) in
84

    
85
	fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\",@ \"vars\": [%a] @]}"
86
	  var
87
	  (pp_expr vars) eq.eq_rhs (* todo_pp_expr expr *)
88
	  (fprintf_list ~sep:", " pp_var_string) vars
89
      )
90
    | _ -> assert false (* should not happen for input of EMF backend (cocospec generated nodes *)
91
  )
92
  | _ -> assert false (* should not happen with EMF backend *)
93

    
94
let pp_node fmt nd =
95
  fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a],@ \"outputs\": [%a],@ "
96
    nd.node_id
97
    pp_node_args nd.node_inputs
98
    pp_node_args nd.node_outputs;
99
  fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"
100
    (fprintf_list ~sep:",@ " pp_stmt ) nd.node_stmts;
101
  fprintf fmt "@]@ }"
102

    
103
let pp_decl fmt decl =
104
  match decl.top_decl_desc with
105
  | Node nd -> fprintf fmt "%a@ " pp_node nd
106
  | ImportedNode _
107
  | Const _
108
  | Open _
109
  | TypeDef _ -> eprintf "should not happen in EMF backend"
110

    
111
let rec pp_val vars fmt v =
112
  match v.value_desc with
113
  | Cst c -> Printers.pp_const fmt c
114
  | LocalVar v
115
  | StateVar v ->
116
     let id = v.var_id in
117
     if List.mem id vars then
118
       Format.fprintf fmt "u(%i)" (get_idx id vars)
119
     else
120
       assert false (* impossible to find element id in var list *)
121
  | Fun (n, vl) -> pp_fun vars n fmt vl
122
  | _ -> assert false (* not available in EMF backend *)
123
and pp_fun vars id fmt vl =
124
  eprintf "print %s with %i args@.@?" id (List.length vl);
125
  match id, vl with
126
    | "+", [v1;v2] -> fprintf fmt "(%a + %a)" (pp_val vars) v1 (pp_val vars) v2
127
    | "uminus", [v] -> fprintf fmt "(- %a)" (pp_val vars) v
128
    | "-", [v1;v2] -> fprintf fmt "(%a - %a)" (pp_val vars) v1 (pp_val vars) v2
129
    | "*",[v1;v2] -> fprintf fmt "(%a * %a)" (pp_val vars) v1 (pp_val vars) v2
130
    | "/", [v1;v2] -> fprintf fmt "(%a / %a)" (pp_val vars) v1 (pp_val vars) v2
131
    | "mod", [v1;v2] -> fprintf fmt "mod (%a, %a)" (pp_val vars) v1 (pp_val vars) v2
132
    | "&&", [v1;v2] -> fprintf fmt "(%a & %a)" (pp_val vars) v1 (pp_val vars) v2
133
    | "||", [v1; v2] -> fprintf fmt "(%a | %a)" (pp_val vars) v1 (pp_val vars) v2
134
    | "xor", [v1; v2] -> fprintf fmt "xor (%a, %a)" (pp_val vars) v1 (pp_val vars) v2
135
    | "impl", [v1; v2] -> fprintf fmt "((~%a) | %a)" (pp_val vars) v1 (pp_val vars) v2
136
    | "<", [v1; v2] -> fprintf fmt "(%a < %a)" (pp_val vars) v1 (pp_val vars) v2
137
    | "<=", [v1; v2] -> fprintf fmt "(%a <= %a)" (pp_val vars) v1 (pp_val vars) v2
138
    | ">", [v1; v2] -> fprintf fmt "(%a > %a)" (pp_val vars) v1 (pp_val vars) v2
139
    | ">=", [v1; v2] -> fprintf fmt "(%a >= %a)" (pp_val vars) v1 (pp_val vars) v2
140
    | "!=", [v1; v2] -> fprintf fmt "(%a != %a)" (pp_val vars) v1 (pp_val vars) v2
141
    | "=", [v1; v2] -> fprintf fmt "(%a = %a)" (pp_val vars) v1 (pp_val vars) v2
142
    | "not", [v] -> fprintf fmt "(~%a)" (pp_val vars) v
143
    | _ -> fprintf fmt "%s (%a)" id  (Utils.fprintf_list ~sep:", " (pp_val vars)) vl 
144

    
145

    
146
     
147
let rec pp_instr m vars fmt i =
148
  match i with
149
  | MLocalAssign (var,v) 
150
  | MStateAssign (var,v) -> fprintf fmt "y = %a" (pp_val vars) v
151
  | MStep ([var], i, vl)  -> (
152
    let name = (Machine_code.get_node_def i m).node_id in
153
    match name, vl with
154
      "_arrow", [v1; v2] -> (
155
	match v1.value_desc, v2.value_desc with
156
	| Cst c1, Cst 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 *)
157
	| _ -> assert false
158
      )
159
    | _ -> raise (Unhandled ("call to node " ^ name))
160
  )
161
  | MBranch (g,[(tag1,case1);(tag2,case2)])     ->
162
     let then_case, else_case =
163
       if tag1 = Corelang.tag_true then
164
	 case1, case2
165
       else
166
	 case2, case1
167
     in
168
     fprintf fmt "if %a; %a; else %a; end"
169
       (pp_val vars) g
170
       (pp_instrs m vars) then_case
171
       (pp_instrs m vars) else_case
172
  | MStep _ (* only single output for function call *)
173
  | MBranch _ (* EMF backend only accept true/false ite *)
174
  | MReset _           
175
  | MNoReset _
176
  | MComment _ -> assert false (* not  available for EMF output *)
177
and pp_instrs m vars fmt il =
178
  fprintf fmt "@[<v 2>%a@]" (Utils.fprintf_list ~sep:"@," (pp_instr m vars)) il
179

    
180
let rec get_instr_var i =
181
  match i with
182
  | MLocalAssign (var,_) 
183
  | MStateAssign (var,_) 
184
  | MStep ([var], _, _)  -> var 
185
  | MBranch (_,[(tag1,case1);(tag2,case2)])     ->
186
     get_instrs_var case1 (* assuming case1 and case2 define the same variable *)
187
  | MStep _ (* only single output for function call *)
188
  | MBranch _ (* EMF backend only accept true/false ite *)
189
  | MReset _           
190
  | MNoReset _
191
  | MComment _ -> assert false (* not  available for EMF output *)
192
and get_instrs_var il =
193
  match il with
194
  | i::_ -> get_instr_var i (* looking for the first instr *)
195
  | _ -> assert false
196

    
197
let rec  get_val_vars v =
198
  match v.value_desc with
199
  | Cst c -> Utils.ISet.empty
200
  | LocalVar v
201
  | StateVar v -> Utils.ISet.singleton v.var_id
202
  | Fun (n, vl) -> List.fold_left (fun res v -> Utils.ISet.union (get_val_vars v) res) Utils.ISet.empty vl
203
  | _ -> assert false (* not available in EMF backend *)
204
  
205
let rec get_instr_vars i =
206
  match i with
207
  | MLocalAssign (_,v)  
208
  | MStateAssign (_,v) -> get_val_vars v
209
  | MStep ([_], _, vl)  -> List.fold_left (fun res v -> Utils.ISet.union res (get_val_vars v)) Utils.ISet.empty vl 
210
  | MBranch (c,[(_,case1);(_,case2)])     ->
211
     Utils.ISet.union
212
       (get_val_vars c)
213
       (
214
	 Utils.ISet.union
215
	   (get_instrs_vars case1)
216
	   (get_instrs_vars case2)
217
       )
218
  | MStep _ (* only single output for function call *)
219
  | MBranch _ (* EMF backend only accept true/false ite *)
220
  | MReset _           
221
  | MNoReset _
222
  | MComment _ -> assert false (* not  available for EMF output *)
223
and get_instrs_vars il =
224
  List.fold_left (fun res i -> Utils.ISet.union res (get_instr_vars i))
225
    Utils.ISet.empty
226
    il
227
    
228
let pp_instr_main m fmt i =
229
  (* first, we extract the expression and associated variables *)
230
  let var = get_instr_var i in
231
  let vars = Utils.ISet.elements (get_instr_vars i) in	
232
  fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\",@ \"vars\": [%a] @]}"
233
    var.var_id
234
    (pp_instr m vars) i
235
    (fprintf_list ~sep:", " pp_var_string) vars
236
    
237
     
238
let pp_machine fmt m =
239
  try
240
    fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a],@ \"outputs\": [%a],@ "
241
      m.mname.node_id
242
      pp_node_args m.mstep.step_inputs
243
      pp_node_args m.mstep.step_outputs;
244
    fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"
245
      (fprintf_list ~sep:",@ " (pp_instr_main m)) m.mstep.step_instrs;
246
    fprintf fmt "@]@ }"
247
  with Unhandled msg -> (
248
    eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
249
      m.mname.node_id;
250
    eprintf "%s@ " msg;
251
    eprintf "node skipped - no output generated@ @]@."
252
  )
253
    
254
let translate fmt prog machines =
255
  fprintf fmt "@[<v 0>{@ ";
256
  (* fprintf_list ~sep:",@ " pp_decl fmt prog; *)
257
  fprintf_list ~sep:",@ " pp_machine fmt machines;
258
  fprintf fmt "@ @]}"