Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / Horn / horn_backend_printers.ml @ cf9cc6f9

History | View | Annotate | Download (15.2 KB)

1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
(* The compilation presented here was first defined in Garoche, Gurfinkel,
13
   Kahsai, HCSV'14.
14

    
15
   This is a modified version that handle reset
16
*)
17

    
18
open Format
19
open LustreSpec
20
open Corelang
21
open Machine_code
22

    
23
open Horn_backend_common
24

    
25

    
26
(********************************************************************************************)
27
(*                    Instruction Printing functions                                        *)
28
(********************************************************************************************)
29

    
30
let pp_horn_var m fmt id =
31
  if Types.is_array_type id.var_type
32
  then
33
    assert false (* no arrays in Horn output *)
34
  else
35
    fprintf fmt "%s" id.var_id
36

    
37
(* Used to print boolean constants *)
38
let pp_horn_tag fmt t =
39
  pp_print_string fmt (if t = tag_true then "true" else if t = tag_false then "false" else t)
40

    
41
(* Prints a constant value *)
42
let rec pp_horn_const fmt c =
43
  match c with
44
    | Const_int i    -> pp_print_int fmt i
45
    | Const_real r   -> pp_print_string fmt r
46
    | Const_float r  -> pp_print_float fmt r
47
    | Const_tag t    -> pp_horn_tag fmt t
48
    | _              -> assert false
49

    
50
(* Prints a value expression [v], with internal function calls only.
51
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
52
   but an offset suffix may be added for array variables
53
*)
54
let rec pp_horn_val ?(is_lhs=false) self pp_var fmt v =
55
  match v with
56
    | Cst c         -> pp_horn_const fmt c
57
    | Array _
58
    | Access _ -> assert false (* no arrays *)
59
    | Power (v, n)  -> assert false
60
    | LocalVar v    -> pp_var fmt (rename_machine self v)
61
    | StateVar v    ->
62
      if Types.is_array_type v.var_type
63
      then assert false
64
      else pp_var fmt (rename_machine self ((if is_lhs then rename_next else rename_current) (* self *) v))
65
    | Fun (n, vl)   -> fprintf fmt "%a" (Basic_library.pp_horn n (pp_horn_val self pp_var)) vl
66

    
67
(* Prints a [value] indexed by the suffix list [loop_vars] *)
68
let rec pp_value_suffix self pp_value fmt value =
69
 match value with
70
 | Fun (n, vl)  ->
71
   Basic_library.pp_horn n (pp_value_suffix self pp_value) fmt vl
72
 |  _            ->
73
   pp_horn_val self pp_value fmt value
74

    
75
(* type_directed assignment: array vs. statically sized type
76
   - [var_type]: type of variable to be assigned
77
   - [var_name]: name of variable to be assigned
78
   - [value]: assigned value
79
   - [pp_var]: printer for variables
80
*)
81
let pp_assign m pp_var fmt var_type var_name value =
82
  let self = m.mname.node_id in
83
  fprintf fmt "(= %a %a)" 
84
    (pp_horn_val ~is_lhs:true self pp_var) var_name
85
    (pp_value_suffix self pp_var) value
86
    
87

    
88
(* In case of no reset call, we define mid_mem = current_mem *)
89
let pp_no_reset machines m fmt i =
90
  let (n,_) = List.assoc i m.minstances in
91
  let target_machine = List.find (fun m  -> m.mname.node_id = (node_name n)) machines in
92

    
93
  let m_list = 
94
    rename_machine_list
95
      (concat m.mname.node_id i)
96
      (rename_mid_list (full_memory_vars machines target_machine))
97
  in
98
  let c_list =
99
    rename_machine_list
100
      (concat m.mname.node_id i)
101
      (rename_current_list (full_memory_vars machines target_machine))
102
  in
103
  match c_list, m_list with
104
  | [chd], [mhd] ->
105
    fprintf fmt "(= %a %a)"
106
      (pp_horn_var m) mhd
107
      (pp_horn_var m) chd
108
  
109
  | _ -> (
110
    fprintf fmt "@[<v 0>(and @[<v 0>";
111
    List.iter2 (fun mhd chd -> 
112
      fprintf fmt "(= %a %a)@ "
113
      (pp_horn_var m) mhd
114
      (pp_horn_var m) chd
115
    )
116
      m_list
117
      c_list      ;
118
    fprintf fmt ")@]@ @]"
119
  )
120

    
121
let pp_instance_reset machines m fmt i =
122
  let (n,_) = List.assoc i m.minstances in
123
  let target_machine = List.find (fun m  -> m.mname.node_id = (node_name n)) machines in
124
  
125
  fprintf fmt "(%a @[<v 0>%a)@]"
126
    pp_machine_reset_name (node_name n)
127
    (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) 
128
    (
129
      (rename_machine_list
130
	 (concat m.mname.node_id i)
131
	 (rename_current_list (full_memory_vars machines target_machine))
132
      ) 
133
      @
134
	(rename_machine_list
135
	   (concat m.mname.node_id i)
136
	   (rename_mid_list (full_memory_vars machines target_machine))
137
	)
138
    )
139

    
140
let pp_instance_call machines reset_instances m fmt i inputs outputs =
141
  let self = m.mname.node_id in
142
  try (* stateful node instance *)
143
    begin
144
      let (n,_) = List.assoc i m.minstances in
145
      let target_machine = List.find (fun m  -> m.mname.node_id = node_name n) machines in
146
      (* Checking whether this specific instances has been reset yet *)
147
      if not (List.mem i reset_instances) then
148
	(* If not, declare mem_m = mem_c *)
149
	pp_no_reset machines m fmt i;
150
      
151
      let mems = full_memory_vars machines target_machine in
152
      let rename_mems f = rename_machine_list (concat m.mname.node_id i) (f mems) in
153
      let mid_mems = rename_mems rename_mid_list in
154
      let next_mems = rename_mems rename_next_list in
155

    
156
      match node_name n, inputs, outputs, mid_mems, next_mems with
157
      | "_arrow", [i1; i2], [o], [mem_m], [mem_x] -> begin
158
	fprintf fmt "@[<v 5>(and ";
159
	fprintf fmt "(= %a (ite %a %a %a))"
160
	  (pp_horn_val ~is_lhs:true self (pp_horn_var m)) (LocalVar o) (* output var *)
161
	  (pp_horn_var m) mem_m 
162
	  (pp_horn_val self (pp_horn_var m)) i1
163
	  (pp_horn_val self (pp_horn_var m)) i2
164
	;
165
	fprintf fmt "@ ";
166
	fprintf fmt "(= %a false)" (pp_horn_var m) mem_x;
167
	fprintf fmt ")@]"
168
      end
169

    
170
      | node_name_n -> begin
171
	fprintf fmt "(%a @[<v 0>%a%t%a%t%a)@]"
172
	  pp_machine_step_name (node_name n)
173
	  (Utils.fprintf_list ~sep:"@ " (pp_horn_val self (pp_horn_var m))) inputs
174
	  (Utils.pp_final_char_if_non_empty "@ " inputs)
175
	  (Utils.fprintf_list ~sep:"@ " (pp_horn_val self (pp_horn_var m)))
176
	  (List.map (fun v -> LocalVar v) outputs)
177
	  (Utils.pp_final_char_if_non_empty "@ " outputs)
178
	  (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (mid_mems@next_mems)
179
	
180
      end
181
    end
182
  with Not_found -> ( (* stateless node instance *)
183
    let (n,_) = List.assoc i m.mcalls in
184
    fprintf fmt "(%s @[<v 0>%a%t%a)@]"
185
      (node_name n)
186
      (Utils.fprintf_list ~sep:"@ " (pp_horn_val self (pp_horn_var m)))
187
      inputs
188
      (Utils.pp_final_char_if_non_empty "@ " inputs)
189
      (Utils.fprintf_list ~sep:"@ " (pp_horn_val self (pp_horn_var m)))
190
      (List.map (fun v -> LocalVar v) outputs)
191
  )
192

    
193

    
194
(* let rec pp_bool_conditional machines ?(init=false)  (m: machine_t) self fmt c tl el = *)
195
(*   fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}" *)
196
(*     (pp_horn_val self (pp_horn_var m)) c *)
197
(*     (Utils.pp_newline_if_non_empty tl) *)
198
(*     (Utils.fprintf_list ~sep:"@," (pp_machine_instr machines ~init:init  m self)) tl *)
199
(*     (Utils.pp_newline_if_non_empty el) *)
200
(*     (Utils.fprintf_list ~sep:"@," (pp_machine_instr machines ~init:init  m self)) el *)
201

    
202
(* and pp_enum_conditional machines ?(init=false)  (m: machine_t) self fmt g hl = *)
203
(* (\* TODO: check that the enum has all its constructor defined: Xavier how have you handled that, could we have partial definition? *\) *)
204
(*   match hl with *)
205
(*   | [] -> assert false *)
206
(*   | [el] -> Utils.fprintf_list ~sep:"@," (pp_machine_instr machines ~init:init  m self) fmt el *)
207
(*   | hd::tl -> *)
208
(*   fprintf fmt "@[<v 2>if (= %a %a) {%t%a@]@,@[<v 2>} else {@.(%a)xxxx@]@,}" *)
209
(*     (pp_horn_val self (pp_horn_var m)) c *)
210
(*     TODOg *)
211
(*     (Utils.pp_newline_if_non_empty tl) *)
212
(*     (Utils.fprintf_list ~sep:"@," (pp_machine_instr machines ~init:init  m self)) hd *)
213
(*     pp_print_newline fmt; *)
214
    
215
    
216
(* Print the instruction and update the set of reset instances *)
217
let rec pp_machine_instr machines reset_instances (m: machine_t) fmt instr : ident list =
218
  match instr with
219
  | MNoReset i -> (* we assign middle_mem with mem_m. And declare i as reset *)
220
    pp_no_reset machines m fmt i;
221
    i::reset_instances
222
  | MReset i -> (* we assign middle_mem with reset: reset(mem_m) *)
223
    pp_instance_reset machines m fmt i;
224
    i::reset_instances
225
  | MLocalAssign (i,v) ->
226
    pp_assign
227
      m (pp_horn_var m) fmt
228
      i.var_type (LocalVar i) v;
229
    reset_instances
230
  | MStateAssign (i,v) ->
231
    pp_assign
232
      m (pp_horn_var m) fmt
233
      i.var_type (StateVar i) v;
234
    reset_instances
235
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
236
    assert false (* This should not happen anymore *)
237
  | MStep (il, i, vl) ->
238
    (* if reset instance, just print the call over mem_m , otherwise declare mem_m =
239
       mem_c and print the call to mem_m *)
240
    pp_instance_call machines reset_instances m fmt i vl il;
241
    reset_instances (* Since this instance call will only happen once, we
242
		       don't have to update reset_instances *)
243

    
244
  | MBranch (g,hl) -> (* (g = tag1 => expr1) and (g = tag2 => expr2) ...
245
			 should not be produced yet. Later, we will have to
246
			 compare the reset_instances of each branch and
247
			 introduced the mem_m = mem_c for branches to do not
248
			 address it while other did. Am I clear ? *)
249
    (* For each branch we obtain the logical encoding, and the information
250
       whether a sub node has been reset or not. If a node has been reset in one
251
       of the branch, then all others have to have the mem_m = mem_c
252
       statement. *)
253
    let self = m.mname.node_id in
254
    let pp_branch fmt (tag, instrs) =
255
      fprintf fmt "@[<v 3>(=> (= %a %s)@ "
256
	(pp_horn_val self (pp_horn_var m)) g
257
	tag;
258
      let rs = pp_machine_instrs machines reset_instances m fmt instrs in
259
      fprintf fmt "@])";
260
      () (* rs *)
261
    in
262
    pp_conj pp_branch fmt hl;
263
    reset_instances (* TODO: le code est faux en ce qui concerne les resets. Il
264
		       faut calculer ce qui se passe sur chaque branche et rajouter les instructions
265
		       adequates *)
266
	     
267
(* if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false *)
268
(* then (\* boolean case, needs special treatment in C because truth value is not unique *\) *)
269
(*   (\* may disappear if we optimize code by replacing last branch test with default *\) *)
270
(*   let tl = try List.assoc tag_true  hl with Not_found -> [] in *)
271
(*   let el = try List.assoc tag_false hl with Not_found -> [] in *)
272
(*   pp_bool_conditional machines ~init:init m self fmt g tl el *)
273
(* else (\* enum type case *\) *)
274

    
275
(*   pp_enum_conditional machines ~init:init m self fmt g hl  *)
276
and pp_machine_instrs machines reset_instances m fmt instrs = 
277
  let ppi rs fmt i = pp_machine_instr machines rs m fmt i in
278
  match instrs with
279
  | [x] -> ppi reset_instances fmt x 
280
  | _::_ ->
281
    fprintf fmt "(and @[<v 0>";
282
    let rs = List.fold_left (fun rs i -> 
283
      let rs = ppi rs fmt i in
284
      fprintf fmt "@ ";
285
      rs
286
    )
287
      reset_instances instrs 
288
    in
289
    fprintf fmt "@])";
290
    rs
291

    
292
  | [] -> fprintf fmt "true"; reset_instances
293

    
294
let pp_machine_reset machines fmt m =
295
  let locals = local_memory_vars machines m in
296
  fprintf fmt "@[<v 5>(and @ ";
297

    
298
  (* print "x_m = x_c" for each local memory *)
299
  (Utils.fprintf_list ~sep:"@ " (fun fmt v -> 
300
    fprintf fmt "(= %a %a)"
301
      (pp_horn_var m) (rename_mid v)
302
      (pp_horn_var m) (rename_current v)
303
   )) fmt locals;
304
  fprintf fmt "@ ";
305

    
306
  (* print "child_reset ( associated vars _ {c,m} )" for each subnode.
307
     Special treatment for _arrow: _first = true
308
  *)
309
  (Utils.fprintf_list ~sep:"@ " (fun fmt (id, (n, _)) ->
310
    let name = node_name n in
311
    if name = "_arrow" then ( 
312
      fprintf fmt "(= %s._arrow._first_m true)"
313
	(concat m.mname.node_id id)  
314
    ) else (
315
      let machine_n = get_machine machines name in 
316
      fprintf fmt "(%s_reset @[<hov 0>%a@])" 
317
	name
318
	(Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) 
319
	(rename_machine_list (concat m.mname.node_id id) (reset_vars machines machine_n))
320
    )
321
   )) fmt m.minstances;
322

    
323
  fprintf fmt "@]@ )"
324

    
325

    
326

    
327
(**************************************************************)
328

    
329
let is_stateless m = m.minstances = [] && m.mmemory = []
330

    
331
(* Print the machine m:
332
   two functions: m_init and m_step
333
   - m_init is a predicate over m memories
334
   - m_step is a predicate over old_memories, inputs, new_memories, outputs
335
   We first declare all variables then the two /rules/.
336
*)
337
let print_machine machines fmt m =
338
  if m.mname.node_id = arrow_id then
339
    (* We don't print arrow function *)
340
    ()
341
  else
342
    begin
343
      fprintf fmt "; %s@." m.mname.node_id;
344
      
345
      (* Printing variables *)
346
      Utils.fprintf_list ~sep:"@." pp_decl_var fmt
347
	(
348
	  (inout_vars machines m)@
349
	    (rename_current_list (full_memory_vars machines m)) @
350
	    (rename_mid_list (full_memory_vars machines m)) @
351
	    (rename_next_list (full_memory_vars machines m)) @
352
	    (rename_machine_list m.mname.node_id m.mstep.step_locals)
353
	);
354
      pp_print_newline fmt ();
355

    
356
      if is_stateless m then
357
	begin
358
	  (* Declaring single predicate *)
359
	  fprintf fmt "(declare-rel %a (%a))@."
360
	    pp_machine_stateless_name m.mname.node_id
361
	    (Utils.fprintf_list ~sep:" " pp_type)
362
	    (List.map (fun v -> v.var_type) (inout_vars machines m));
363

    
364
	  (* Rule for single predicate *)
365
	  fprintf fmt "@[<v 2>(rule (=> @ ";
366
	  ignore (pp_machine_instrs machines ([] (* No reset info for stateless nodes *) )  m fmt m.mstep.step_instrs);
367
	  fprintf fmt "@ (%a %a)@]@.))@.@."
368
	    pp_machine_stateless_name m.mname.node_id
369
	    (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (inout_vars machines m);
370
	end
371
      else
372
	begin
373
	  (* Declaring predicate *)
374
	  fprintf fmt "(declare-rel %a (%a))@."
375
	    pp_machine_reset_name m.mname.node_id
376
	    (Utils.fprintf_list ~sep:" " pp_type)
377
	    (List.map (fun v -> v.var_type) (reset_vars machines m));
378

    
379
	  fprintf fmt "(declare-rel %a (%a))@."
380
	    pp_machine_step_name m.mname.node_id
381
	    (Utils.fprintf_list ~sep:" " pp_type)
382
	    (List.map (fun v -> v.var_type) (step_vars machines m));
383

    
384
	  pp_print_newline fmt ();
385

    
386
	  (* Rule for reset *)
387
	  fprintf fmt "@[<v 2>(rule (=> @ %a@ (%a @[<v 0>%a)@]@]@.))@.@."
388
	    (pp_machine_reset machines) m 
389
	    pp_machine_reset_name m.mname.node_id
390
	    (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (reset_vars machines m);
391

    
392
          match m.mstep.step_asserts with
393
	  | [] ->
394
	    begin
395

    
396
	      (* Rule for step*)
397
	      fprintf fmt "@[<v 2>(rule (=> @ ";
398
	      ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
399
	      fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@."
400
		pp_machine_step_name m.mname.node_id
401
		(Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (step_vars machines m);
402
	    end
403
	  | assertsl -> 
404
	    begin
405
	      let pp_val = pp_horn_val ~is_lhs:true m.mname.node_id (pp_horn_var m) in
406
	      (* print_string pp_val; *)
407
	      fprintf fmt "; with Assertions @.";
408
	      
409
	      (*Rule for step*)
410
	      fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
411
	      ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
412
	      fprintf fmt "@. %a)(%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val) assertsl
413
		pp_machine_step_name m.mname.node_id
414
		(Utils.fprintf_list ~sep:" " (pp_horn_var m)) (step_vars machines m);
415
	    end
416
	      
417
	      
418
	end
419
    end
420

    
421

    
422
(* Local Variables: *)
423
(* compile-command:"make -C ../.." *)
424
(* End: *)