Project

General

Profile

Download (10.3 KB) Statistics
| Branch: | Tag: | Revision:
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; %a; else %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
    
78
let pp_stmt fmt stmt =
79
  match stmt with
80
  | Eq eq -> (
81
    match eq.eq_lhs with
82
      [var] -> (
83
     (* first, we extract the expression and associated variables *)
84
	let vars = Utils.ISet.elements (Corelang.get_expr_vars eq.eq_rhs) in
85
	
86
	fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\",@ \"vars\": [%a] @]}"
87
	  var
88
	  (pp_expr vars) eq.eq_rhs (* todo_pp_expr expr *)
89
	  (fprintf_list ~sep:", " pp_var_string) vars
90
      )
91
    | _ -> assert false (* should not happen for input of EMF backend (cocospec generated nodes *)
92
  )
93
  | _ -> assert false (* should not happen with EMF backend *)
94

    
95
let pp_node fmt nd =
96
  fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a],@ \"outputs\": [%a],@ "
97
    nd.node_id
98
    pp_node_args nd.node_inputs
99
    pp_node_args nd.node_outputs;
100
  fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"
101
    (fprintf_list ~sep:",@ " pp_stmt ) nd.node_stmts;
102
  fprintf fmt "@]@ }"
103
    
104
let pp_decl fmt decl =
105
  match decl.top_decl_desc with
106
  | Node nd -> fprintf fmt "%a@ " pp_node nd
107
  | ImportedNode _ 
108
  | Const _
109
  | Open _ 
110
  | TypeDef _ -> eprintf "should not happen in EMF backend"
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 
145

    
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 =
256
  fprintf fmt "@[<v 0>{@ ";
257
  (* fprintf_list ~sep:",@ " pp_decl fmt prog; *)
258
  fprintf_list ~sep:",@ " pp_machine fmt machines;
259
  fprintf fmt "@ @]}"
260

    
(1-1/2)