Project

General

Profile

« Previous | Next » 

Revision 7d62bf41

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

Merged code

View differences:

src/backends/EMF/EMF_backend.ml
1 1
open LustreSpec
2
open Machine_code
2 3
open Format
3 4
open Utils
4 5

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

  
8 11
let pp_node_args = fprintf_list ~sep:", " pp_var_name
9 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
     
10 19
let pp_expr vars fmt expr =
11
  (* simple function to extract the element id in the list. Starts from 1. *)
12
  let rec get_idx x l =
13
    match l with
14
    | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
15
    | [] -> assert false
16
  in
17 20
  let rec pp_expr fmt expr =
18 21
    match expr.expr_desc with
19 22
    | Expr_const c -> Printers.pp_const fmt c
......
71 74
  in
72 75
  pp_expr fmt expr
73 76

  
74
(*
75
let rec translate_expr expr vars =
76
  match expr with
77
    match expr.expr_desc with
78
    | Expr_const _ -> expr, vars
79
    | Expr_ident id -> if List.exists id Format.fprintf fmt "%s" id
80
    | Expr_array a -> fprintf fmt "[%a]" pp_tuple a
81
    | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
82
    | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
83
    | Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
84
    | Expr_ite (c, t, e) -> fprintf fmt "(if %a then %a else %a)" pp_expr c pp_expr t pp_expr e
85
    | Expr_arrow (e1, e2) -> fprintf fmt "(%a -> %a)" pp_expr e1 pp_expr e2
86
    | Expr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_expr e1 pp_expr e2
87
    | Expr_pre e -> fprintf fmt "pre %a" pp_expr e
88
    | Expr_when (e, id, l) -> fprintf fmt "%a when %s(%s)" pp_expr e l id
89
    | Expr_merge (id, hl) -> 
90
      fprintf fmt "merge %s %a" id pp_handlers hl
91
    | Expr_appl (id, e, r) -> pp_app fmt id e r
92
*)
93 77
    
94 78
let pp_stmt fmt stmt =
95 79
  match stmt with
......
125 109
  | Open _ 
126 110
  | TypeDef _ -> eprintf "should not happen in EMF backend"
127 111

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

  
129
let translate fmt prog =
146

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

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

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

  

Also available in: Unified diff