Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / tools / zustre / zustre_common.ml @ 7d77632f

History | View | Annotate | Download (29 KB)

1
open Lustre_types
2
open Machine_code_types
3
open Machine_code_common
4
open Format
5
(* open Horn_backend_common
6
 * open Horn_backend *)
7
open Zustre_data
8

    
9
module HBC = Horn_backend_common
10
let node_name = HBC.node_name
11

    
12
let concat = HBC.concat
13

    
14
let rename_machine = HBC.rename_machine
15
let rename_machine_list = HBC.rename_machine_list
16

    
17
let rename_next = HBC.rename_next
18
let rename_mid = HBC.rename_mid
19
let rename_current = HBC.rename_current
20

    
21
let rename_current_list = HBC.rename_current_list
22
let rename_mid_list = HBC.rename_mid_list
23
let rename_next_list = HBC.rename_next_list
24

    
25
let full_memory_vars = HBC.full_memory_vars
26
let inout_vars = HBC.inout_vars
27
let reset_vars = HBC.reset_vars
28
let step_vars = HBC.step_vars
29
let local_memory_vars = HBC.local_memory_vars
30
let step_vars_m_x = HBC.step_vars_m_x
31
let step_vars_c_m_x = HBC.step_vars_c_m_x
32
  
33
let machine_reset_name = HBC.machine_reset_name 
34
let machine_step_name = HBC.machine_step_name 
35
let machine_stateless_name = HBC.machine_stateless_name 
36

    
37
let preprocess = Horn_backend.preprocess
38
  
39
  
40
(** Sorts
41

    
42
A sort is introduced for each basic type and each enumerated type.
43

    
44
A hashtbl records these and allow easy access to sort values, when
45
   provided with a enumerated type name. 
46

    
47
*)
48
        
49
let bool_sort = Z3.Boolean.mk_sort !ctx
50
let int_sort = Z3.Arithmetic.Integer.mk_sort !ctx
51
let real_sort = Z3.Arithmetic.Real.mk_sort !ctx
52

    
53

    
54
let get_const_sort = Hashtbl.find const_sorts 
55
let get_sort_elems = Hashtbl.find sort_elems
56
let get_tag_sort = Hashtbl.find const_tags
57
  
58

    
59
  
60
let decl_sorts () =
61
  Hashtbl.iter (fun typ decl ->
62
    match typ with
63
    | Tydec_const var ->
64
      (match decl.top_decl_desc with
65
      | TypeDef tdef -> (
66
	match tdef.tydef_desc with
67
	| Tydec_enum tl ->
68
	  let new_sort = Z3.Enumeration.mk_sort_s !ctx var tl in
69
          Hashtbl.add const_sorts var new_sort;
70
          Hashtbl.add sort_elems new_sort tl;
71
          List.iter (fun t -> Hashtbl.add const_tags t new_sort) tl
72
          
73
	| _ -> Format.eprintf "Unknown type : %a@.@?" Printers.pp_var_type_dec_desc typ; assert false
74
      )
75
      | _ -> assert false
76
      )
77
    | _        -> ()) Corelang.type_table
78

    
79
                 
80
let rec type_to_sort t =
81
  if Types.is_bool_type t  then bool_sort else
82
    if Types.is_int_type t then int_sort else 
83
  if Types.is_real_type t then real_sort else 
84
  match (Types.repr t).Types.tdesc with
85
  | Types.Tconst ty       -> get_const_sort ty
86
  | Types.Tclock t        -> type_to_sort t
87
  | Types.Tarray(dim,ty)   -> Z3.Z3Array.mk_sort !ctx int_sort (type_to_sort ty)
88
  | Types.Tstatic(d, ty)-> type_to_sort ty
89
  | Types.Tarrow _
90
  | _                     -> Format.eprintf "internal error: pp_type %a@."
91
                               Types.print_ty t; assert false
92

    
93

    
94
(* let idx_var = *)
95
(*   Z3.FuncDecl.mk_func_decl_s !ctx "__idx__" [] idx_sort  *)
96
    
97
(* let uid_var = *)
98
(*   Z3.FuncDecl.mk_func_decl_s !ctx "__uid__" [] uid_sort  *)
99

    
100
(** Func decls
101

    
102
    Similarly fun_decls are registerd, by their name, into a hashtbl. The
103
    proposed encoding introduces a 0-ary fun_decl to model variables and
104
    fun_decl with arguments to declare reset and step predicates.
105

    
106

    
107

    
108
*)
109
let register_fdecl id fd = Hashtbl.add decls id fd
110
let get_fdecl id =
111
  try
112
    Hashtbl.find decls id
113
  with Not_found -> (Format.eprintf "Unable to find func_decl %s@.@?" id; raise Not_found)
114

    
115
let pp_fdecls fmt =
116
  Format.fprintf fmt "Registered fdecls: @[%a@]@ "
117
    (Utils.fprintf_list ~sep:"@ " Format.pp_print_string)  (Hashtbl.fold (fun id _ accu -> id::accu) decls [])
118

    
119
    
120
let decl_var id =
121
  (* Format.eprintf "Declaring var %s@." id.var_id; *)
122
  let fdecl = Z3.FuncDecl.mk_func_decl_s !ctx id.var_id [] (type_to_sort id.var_type) in
123
  register_fdecl id.var_id fdecl;
124
  fdecl
125

    
126
let idx_sort = int_sort
127
let uid_sort = Z3.Z3List.mk_sort !ctx (Z3.Symbol.mk_string !ctx "uid_list") int_sort
128
let uid_conc = 
129
  let fd = Z3.Z3List.get_cons_decl uid_sort in
130
  fun head tail -> Z3.FuncDecl.apply fd [head;tail]
131

    
132
let get_instance_uid =
133
  let hash : (string, int) Hashtbl.t = Hashtbl.create 13 in
134
  let cpt = ref 0 in
135
  fun i ->
136
    let id =
137
      if Hashtbl.mem hash i then
138
	Hashtbl.find hash i
139
      else (
140
	incr cpt;
141
	Hashtbl.add hash i !cpt;
142
	!cpt
143
      )
144
    in
145
    Z3.Arithmetic.Integer.mk_numeral_i !ctx id
146
  
147

    
148
  
149
let decl_rel ?(no_additional_vars=false) name args_sorts =
150
  (* Enriching arg_sorts with two new variables: a counting index and an
151
     uid *)
152
  let args_sorts =
153
    if no_additional_vars then args_sorts else idx_sort::uid_sort::args_sorts in
154
  
155
  (* let args_sorts = List.map (fun v -> type_to_sort v.var_type) args in *)
156
  if !debug then
157
    Format.eprintf "Registering fdecl %s (%a)@."
158
      name
159
      (Utils.fprintf_list ~sep:"@ "
160
	 (fun fmt sort -> Format.fprintf fmt "%s" (Z3.Sort.to_string sort)))
161
      args_sorts
162
  ;
163
  let fdecl = Z3.FuncDecl.mk_func_decl_s !ctx name args_sorts bool_sort in
164
  Z3.Fixedpoint.register_relation !fp fdecl;
165
  register_fdecl name fdecl;
166
  fdecl
167
  
168

    
169

    
170
(* Shared variables to describe counter and uid *)
171

    
172
let idx = Corelang.dummy_var_decl "__idx__" Type_predef.type_int
173
let idx_var = Z3.Expr.mk_const_f !ctx (decl_var idx) 
174
let uid = Corelang.dummy_var_decl "__uid__" Type_predef.type_int
175
let uid_fd = Z3.FuncDecl.mk_func_decl_s !ctx "__uid__" [] uid_sort 
176
let _ = register_fdecl "__uid__"  uid_fd  
177
let uid_var = Z3.Expr.mk_const_f !ctx uid_fd 
178

    
179
(** Conversion functions
180

    
181
    The following is similar to the Horn backend. Each printing function is
182
    rephrased from pp_xx to xx_to_expr and produces a Z3 value.
183

    
184
*)
185

    
186

    
187
(* Returns the f_decl associated to the variable v *)
188
let horn_var_to_expr v =
189
  Z3.Expr.mk_const_f !ctx (get_fdecl v.var_id)
190

    
191

    
192

    
193

    
194
  (* Used to print boolean constants *)
195
let horn_tag_to_expr t =
196
  if t = Corelang.tag_true then
197
    Z3.Boolean.mk_true !ctx
198
  else if t = Corelang.tag_false then
199
    Z3.Boolean.mk_false !ctx
200
  else
201
    (* Finding the associated sort *)
202
    let sort = get_tag_sort t in
203
    let elems = get_sort_elems sort in 
204
    let res : Z3.Expr.expr option =
205
      List.fold_left2 (fun res cst expr ->
206
          match res with
207
          | Some _ -> res
208
          | None -> if t = cst then Some (expr:Z3.Expr.expr) else None
209
        ) None elems (Z3.Enumeration.get_consts sort)
210
    in
211
    match res with None -> assert false | Some s -> s
212
    
213
(* Prints a constant value *)
214
let rec horn_const_to_expr c =
215
  match c with
216
    | Const_int i    -> Z3.Arithmetic.Integer.mk_numeral_i !ctx i
217
    | Const_real (_,_,s)   -> Z3.Arithmetic.Real.mk_numeral_i !ctx 0
218
    | Const_tag t    -> horn_tag_to_expr t
219
    | _              -> assert false
220

    
221

    
222

    
223
(* Default value for each type, used when building arrays. Eg integer array
224
   [2;7] is defined as (store (store (0) 1 7) 0 2) where 0 is this default value
225
   for the type integer (arrays).
226
*)
227
let rec horn_default_val t =
228
  let t = Types.dynamic_type t in
229
  if Types.is_bool_type t  then Z3.Boolean.mk_true !ctx else
230
  if Types.is_int_type t then Z3.Arithmetic.Integer.mk_numeral_i !ctx 0 else 
231
  if Types.is_real_type t then Z3.Arithmetic.Real.mk_numeral_i !ctx 0 else 
232
  (* match (Types.dynamic_type t).Types.tdesc with
233
   * | Types.Tarray(dim, l) -> (\* TODO PL: this strange code has to be (heavily) checked *\)
234
   *    let valt = Types.array_element_type t in
235
   *    fprintf fmt "((as const (Array Int %a)) %a)"
236
   *      pp_type valt 
237
   *      pp_default_val valt
238
   * | Types.Tstruct(l) -> assert false
239
   * | Types.Ttuple(l) -> assert false
240
   * |_ -> *) assert false
241

    
242
(* Conversion of basic library functions *)
243
    
244
let horn_basic_app i val_to_expr vl =
245
  match i, vl with
246
  | "ite", [v1; v2; v3] ->
247
     Z3.Boolean.mk_ite
248
       !ctx
249
       (val_to_expr v1)
250
       (val_to_expr v2)
251
       (val_to_expr v3)
252

    
253
  | "uminus", [v] ->
254
     Z3.Arithmetic.mk_unary_minus
255
       !ctx
256
       (val_to_expr v)
257
  | "not", [v] ->
258
     Z3.Boolean.mk_not
259
       !ctx
260
       (val_to_expr v)
261
  | "=", [v1; v2] ->
262
     Z3.Boolean.mk_eq
263
       !ctx
264
       (val_to_expr v1)
265
       (val_to_expr v2)
266
  | "&&", [v1; v2] ->
267
     Z3.Boolean.mk_and
268
       !ctx
269
       [val_to_expr v1;
270
        val_to_expr v2]
271
  | "||", [v1; v2] ->
272
          Z3.Boolean.mk_or
273
       !ctx
274
       [val_to_expr v1;
275
        val_to_expr v2]
276

    
277
  | "impl", [v1; v2] ->
278
     Z3.Boolean.mk_implies
279
       !ctx
280
       (val_to_expr v1)
281
       (val_to_expr v2)
282
 | "mod", [v1; v2] ->
283
          Z3.Arithmetic.Integer.mk_mod
284
       !ctx
285
       (val_to_expr v1)
286
       (val_to_expr v2)
287
  | "equi", [v1; v2] ->
288
          Z3.Boolean.mk_eq
289
       !ctx
290
       (val_to_expr v1)
291
       (val_to_expr v2)
292
  | "xor", [v1; v2] ->
293
          Z3.Boolean.mk_xor
294
       !ctx
295
       (val_to_expr v1)
296
       (val_to_expr v2)
297
  | "!=", [v1; v2] ->
298
     Z3.Boolean.mk_not
299
       !ctx
300
       (
301
         Z3.Boolean.mk_eq
302
           !ctx
303
           (val_to_expr v1)
304
           (val_to_expr v2)
305
       )
306
  | "/", [v1; v2] ->
307
     Z3.Arithmetic.mk_div
308
       !ctx
309
       (val_to_expr v1)
310
       (val_to_expr v2)
311

    
312
  | "+", [v1; v2] ->
313
     Z3.Arithmetic.mk_add
314
       !ctx
315
       [val_to_expr v1; val_to_expr v2]
316

    
317
  | "-", [v1; v2] ->
318
     Z3.Arithmetic.mk_sub
319
       !ctx
320
       [val_to_expr v1 ; val_to_expr v2]
321
       
322
  | "*", [v1; v2] ->
323
     Z3.Arithmetic.mk_mul
324
       !ctx
325
       [val_to_expr v1; val_to_expr v2]
326

    
327

    
328
  | "<", [v1; v2] ->
329
     Z3.Arithmetic.mk_lt
330
       !ctx
331
       (val_to_expr v1)
332
       (val_to_expr v2)
333

    
334
  | "<=", [v1; v2] ->
335
     Z3.Arithmetic.mk_le
336
       !ctx
337
       (val_to_expr v1)
338
       (val_to_expr v2)
339

    
340
  | ">", [v1; v2] ->
341
     Z3.Arithmetic.mk_gt
342
       !ctx
343
       (val_to_expr v1)
344
       (val_to_expr v2)
345

    
346
  | ">=", [v1; v2] ->
347
     Z3.Arithmetic.mk_ge
348
       !ctx
349
       (val_to_expr v1)
350
       (val_to_expr v2)
351

    
352
       
353
  (* | _, [v1; v2] ->      Z3.Boolean.mk_and
354
   *      !ctx
355
   *      (val_to_expr v1)
356
   *      (val_to_expr v2)
357
   * 
358
   *      Format.fprintf fmt "(%s %a %a)" i val_to_exprr v1 val_to_expr v2 *)
359
  | _ -> (
360
    Format.eprintf
361
      "internal error: zustre unkown function %s@." i;
362
    assert false)
363

    
364
           
365
(* Convert a value expression [v], with internal function calls only.  [pp_var]
366
   is a printer for variables (typically [pp_c_var_read]), but an offset suffix
367
   may be added for array variables
368
*)
369
let rec horn_val_to_expr ?(is_lhs=false) self v =
370
  match v.value_desc with
371
  | Cst c       -> horn_const_to_expr c
372

    
373
  (* Code specific for arrays *)
374
  | Array il    ->
375
     (* An array definition: 
376
	(store (
377
	  ...
378
 	    (store (
379
	       store (
380
	          default_val
381
	       ) 
382
	       idx_n val_n
383
	    ) 
384
	    idx_n-1 val_n-1)
385
	  ... 
386
	  idx_1 val_1
387
	) *)
388
     let rec build_array (tab, x) =
389
       match tab with
390
       | [] -> horn_default_val v.value_type(* (get_type v) *)
391
       | h::t ->
392
	  Z3.Z3Array.mk_store
393
            !ctx
394
	    (build_array (t, (x+1)))
395
	    (Z3.Arithmetic.Integer.mk_numeral_i !ctx x)
396
	    (horn_val_to_expr ~is_lhs:is_lhs self h)
397
     in
398
     build_array (il, 0)
399
       
400
  | Access(tab,index) ->
401
     Z3.Z3Array.mk_select !ctx 
402
       (horn_val_to_expr ~is_lhs:is_lhs self tab)
403
       (horn_val_to_expr ~is_lhs:is_lhs self index)
404

    
405
  (* Code specific for arrays *)
406
    
407
  | Power (v, n)  -> assert false
408
  | LocalVar v    ->
409
     horn_var_to_expr
410
       (rename_machine
411
          self
412
          v)
413
  | StateVar v    ->
414
     if Types.is_array_type v.var_type
415
     then assert false
416
     else horn_var_to_expr (rename_machine self ((if is_lhs then rename_next else rename_current) (* self *) v))
417
  | Fun (n, vl)   -> horn_basic_app n (horn_val_to_expr self) vl
418

    
419
let no_reset_to_exprs machines m i =
420
  let (n,_) = List.assoc i m.minstances in
421
  let target_machine = List.find (fun m  -> m.mname.node_id = (Corelang.node_name n)) machines in
422

    
423
  let m_list = 
424
    rename_machine_list
425
      (concat m.mname.node_id i)
426
      (rename_mid_list (full_memory_vars machines target_machine))
427
  in
428
  let c_list =
429
    rename_machine_list
430
      (concat m.mname.node_id i)
431
      (rename_current_list (full_memory_vars machines target_machine))
432
  in
433
  match c_list, m_list with
434
  | [chd], [mhd] ->
435
     let expr =
436
       Z3.Boolean.mk_eq !ctx 
437
         (horn_var_to_expr mhd)
438
         (horn_var_to_expr chd)
439
     in
440
     [expr]
441
  | _ -> (
442
    let exprs =
443
      List.map2 (fun mhd chd -> 
444
          Z3.Boolean.mk_eq !ctx 
445
            (horn_var_to_expr mhd)
446
            (horn_var_to_expr chd)
447
        )
448
        m_list
449
        c_list
450
    in
451
    exprs
452
  )
453

    
454
let instance_reset_to_exprs machines m i =
455
  let (n,_) = List.assoc i m.minstances in
456
  let target_machine = List.find (fun m  -> m.mname.node_id = (Corelang.node_name n)) machines in
457
  let vars =
458
    (rename_machine_list
459
       (concat m.mname.node_id i)
460
       (rename_current_list (full_memory_vars machines target_machine))@  (rename_mid_list (full_memory_vars machines target_machine))
461
    )
462
    
463
  in
464
  let expr =
465
    Z3.Expr.mk_app
466
      !ctx
467
      (get_fdecl (machine_reset_name (Corelang.node_name n)))
468
      (List.map (horn_var_to_expr) (idx::uid::vars))
469
  in
470
  [expr]
471

    
472
let instance_call_to_exprs machines reset_instances m i inputs outputs =
473
  let self = m.mname.node_id in
474

    
475
  (* Building call args *)
476
  let idx_uid_inout =
477
    (* Additional input to register step counters, and uid *)
478
    let idx = horn_var_to_expr idx in
479
    let uid = uid_conc (get_instance_uid i) (horn_var_to_expr uid) in
480
    let inout = 
481
      List.map (horn_val_to_expr self)
482
	(inputs @ (List.map (fun v -> mk_val (LocalVar v) v.var_type) outputs))
483
    in
484
    idx::uid::inout
485
  in
486
    
487
  try (* stateful node instance *)
488
    begin
489
      let (n,_) = List.assoc i m.minstances in
490
      let target_machine = List.find (fun m  -> m.mname.node_id = Corelang.node_name n) machines in
491

    
492
      (* Checking whether this specific instances has been reset yet *)
493
      let reset_exprs = 
494
        if not (List.mem i reset_instances) then
495
	  (* If not, declare mem_m = mem_c *)
496
	  no_reset_to_exprs machines m i
497
        else
498
          [] (* Nothing to add yet *)
499
      in
500
      
501
      let mems = full_memory_vars machines target_machine in
502
      let rename_mems f = rename_machine_list (concat m.mname.node_id i) (f mems) in
503
      let mid_mems = rename_mems rename_mid_list in
504
      let next_mems = rename_mems rename_next_list in
505

    
506
      let call_expr = 
507
	match Corelang.node_name n, inputs, outputs, mid_mems, next_mems with
508
	| "_arrow", [i1; i2], [o], [mem_m], [mem_x] -> begin
509
          let stmt1 = (* out = ite mem_m then i1 else i2 *)
510
            Z3.Boolean.mk_eq !ctx
511
              ( (* output var *)
512
                horn_val_to_expr
513
                  ~is_lhs:true
514
                  self
515
                  (mk_val (LocalVar o) o.var_type)
516
              )
517
              (
518
                Z3.Boolean.mk_ite !ctx 
519
	          (horn_var_to_expr mem_m) 
520
	          (horn_val_to_expr self i1)
521
	          (horn_val_to_expr self i2)
522
              )
523
          in
524
          let stmt2 = (* mem_X = false *)
525
            Z3.Boolean.mk_eq !ctx
526
	      (horn_var_to_expr mem_x)
527
              (Z3.Boolean.mk_false !ctx)
528
          in
529
          [stmt1; stmt2]
530
	end
531

    
532
	| node_name_n ->
533
           let expr = 
534
             Z3.Expr.mk_app
535
               !ctx
536
               (get_fdecl (machine_step_name (node_name n)))
537
               ( (* Arguments are input, output, mid_mems, next_mems *)
538
		 idx_uid_inout @ List.map (horn_var_to_expr) (mid_mems@next_mems)
539
		    
540
               )
541
           in
542
           [expr]
543
      in
544

    
545
      reset_exprs@call_expr
546
    end
547
  with Not_found -> ( (* stateless node instance *)
548
    let (n,_) = List.assoc i m.mcalls in
549
    let expr = 
550
      Z3.Expr.mk_app
551
        !ctx
552
        (get_fdecl (machine_stateless_name (node_name n)))
553
        idx_uid_inout 	  (* Arguments are inputs, outputs *)
554
    in
555
    [expr]
556
  )
557

    
558

    
559
    
560
(* (\* Prints a [value] indexed by the suffix list [loop_vars] *\) *)
561
(* let rec value_suffix_to_expr self value = *)
562
(*  match value.value_desc with *)
563
(*  | Fun (n, vl)  ->  *)
564
(*     horn_basic_app n (horn_val_to_expr self) (value_suffix_to_expr self vl) *)
565
    
566
(*  |  _            -> *)
567
(*    horn_val_to_expr self value *)
568

    
569

    
570
(* type_directed assignment: array vs. statically sized type
571
   - [var_type]: type of variable to be assigned
572
   - [var_name]: name of variable to be assigned
573
   - [value]: assigned value
574
   - [pp_var]: printer for variables
575
*)
576
let assign_to_exprs m var_name value =
577
  let self = m.mname.node_id in
578
  let e =
579
    Z3.Boolean.mk_eq
580
      !ctx
581
      (horn_val_to_expr ~is_lhs:true self var_name)
582
      (horn_val_to_expr self value)
583
  (* was: TODO deal with array accesses       (value_suffix_to_expr self value) *)
584
  in
585
  [e]
586

    
587
    
588
(* Convert instruction to Z3.Expr and update the set of reset instances *)
589
let rec instr_to_exprs machines reset_instances (m: machine_t) instr : Z3.Expr.expr list * ident list =
590
  match Corelang.get_instr_desc instr with
591
  | MComment _ -> [], reset_instances
592
  | MNoReset i -> (* we assign middle_mem with mem_m. And declare i as reset *)
593
    no_reset_to_exprs machines m i,
594
    i::reset_instances
595
  | MReset i -> (* we assign middle_mem with reset: reset(mem_m) *)
596
    instance_reset_to_exprs machines m i,
597
    i::reset_instances
598
  | MLocalAssign (i,v) ->
599
    assign_to_exprs
600
      m  
601
      (mk_val (LocalVar i) i.var_type) v,
602
    reset_instances
603
  | MStateAssign (i,v) ->
604
    assign_to_exprs
605
      m 
606
      (mk_val (StateVar i) i.var_type) v,
607
    reset_instances
608
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i (List.map (fun v -> v.value_type) vl) ->
609
    assert false (* This should not happen anymore *)
610
  | MStep (il, i, vl) ->
611
    (* if reset instance, just print the call over mem_m , otherwise declare mem_m =
612
       mem_c and print the call to mem_m *)
613
    instance_call_to_exprs machines reset_instances m i vl il,
614
    reset_instances (* Since this instance call will only happen once, we
615
		       don't have to update reset_instances *)
616

    
617
  | MBranch (g,hl) -> (* (g = tag1 => expr1) and (g = tag2 => expr2) ...
618
			 should not be produced yet. Later, we will have to
619
			 compare the reset_instances of each branch and
620
			 introduced the mem_m = mem_c for branches to do not
621
			 address it while other did. Am I clear ? *)
622
    (* For each branch we obtain the logical encoding, and the information
623
       whether a sub node has been reset or not. If a node has been reset in one
624
       of the branch, then all others have to have the mem_m = mem_c
625
       statement. *)
626
    let self = m.mname.node_id in
627
    let branch_to_expr (tag, instrs) =
628
      let branch_def, branch_resets = instrs_to_expr machines reset_instances m instrs in
629
      let e =
630
	Z3.Boolean.mk_implies !ctx
631
          (Z3.Boolean.mk_eq !ctx 
632
             (horn_val_to_expr self g)
633
	     (horn_tag_to_expr tag))
634
          branch_def in
635

    
636
      [e], branch_resets
637
	  
638
    in
639
    List.fold_left (fun (instrs, resets) b ->
640
      let b_instrs, b_resets = branch_to_expr b in
641
      instrs@b_instrs, resets@b_resets 
642
    ) ([], reset_instances) hl 
643

    
644
and instrs_to_expr machines reset_instances m instrs = 
645
  let instr_to_exprs rs i = instr_to_exprs machines rs m i in
646
  let e_list, rs = 
647
    match instrs with
648
    | [x] -> instr_to_exprs reset_instances x 
649
    | _::_ -> (* TODO: check whether we should compuyte a AND on the exprs (expr list) built here. It was performed in the printer setting but seems to be useless here since the output is a list of exprs *)
650
       
651
       List.fold_left (fun (exprs, rs) i -> 
652
         let exprs_i, rs_i = instr_to_exprs rs i in
653
         exprs@exprs_i, rs@rs_i
654
       )
655
         ([], reset_instances) instrs 
656
	 
657
	 
658
    | [] -> [], reset_instances
659
  in
660
  let e = 
661
    match e_list with
662
    | [e] -> e
663
    | [] -> Z3.Boolean.mk_true !ctx
664
    | _ -> Z3.Boolean.mk_and !ctx e_list
665
  in
666
  e, rs
667

    
668

    
669
(*********************************************************)
670

    
671
(* Quantifiying universally all occuring variables *)
672
let add_rule ?(dont_touch=[]) vars  expr =
673
  (* let fds = Z3.Expr.get_args expr in *)
674
  (* Format.eprintf "Expr %s: args: [%a]@." *)
675
  (*   (Z3.Expr.to_string expr) *)
676
  (*   (Utils.fprintf_list ~sep:", " (fun fmt e -> Format.pp_print_string fmt (Z3.Expr.to_string e))) fds; *)
677

    
678
  (* (\* Old code relying on provided vars *\) *)
679
  (* let sorts = (List.map (fun id -> type_to_sort id.var_type) vars) in *)
680
  (* let symbols = (List.map (fun id -> Z3.FuncDecl.get_name (get_fdecl id.var_id)) vars) in *)
681
  
682
  (* New code: we extract vars from expr *)
683
  let module FDSet = Set.Make (struct type t = Z3.FuncDecl.func_decl
684
				      let compare = compare
685
				      let hash = Hashtbl.hash
686
  end)
687
  in
688
  let rec get_expr_vars e =
689
    let open Utils in
690
    let nb_args = Z3.Expr.get_num_args e in
691
    if nb_args <= 0 then (
692
      let fdecl = Z3.Expr.get_func_decl e in
693
      (* let params = Z3.FuncDecl.get_parameters fdecl in *)
694
      (* Format.eprintf "Extracting info about %s: @." (Z3.Expr.to_string e); *)
695
      let dkind = Z3.FuncDecl.get_decl_kind fdecl in
696
      match dkind with Z3enums.OP_UNINTERPRETED -> (
697
	(* Format.eprintf "kind = %s, " (match dkind with Z3enums.OP_TRUE -> "true" | Z3enums.OP_UNINTERPRETED -> "uninter"); *)
698
	(* let open Z3.FuncDecl.Parameter in *)
699
	(* List.iter (fun p -> *)
700
	(*   match p with *)
701
        (*     P_Int i -> Format.eprintf "int %i" i *)
702
	(*   | P_Dbl f -> Format.eprintf "dbl %f" f *)
703
	(*   | P_Sym s -> Format.eprintf "symb"  *)
704
	(*   | P_Srt s -> Format.eprintf "sort"  *)
705
	(*   | P_Ast _ ->Format.eprintf "ast"  *)
706
	(*   | P_Fdl f -> Format.eprintf "fundecl"  *)
707
	(*   | P_Rat s -> Format.eprintf "rat %s" s  *)
708
	     
709
	(* ) params; *)
710
	(* Format.eprintf "]@."; *)
711
	FDSet.singleton fdecl
712
      )
713
      | _ -> FDSet.empty
714
    )
715
    else (*if nb_args > 0 then*)
716
      List.fold_left
717
	(fun accu e ->  FDSet.union accu (get_expr_vars e))
718
	FDSet.empty (Z3.Expr.get_args e)
719
  in
720
  let extracted_vars = FDSet.elements (FDSet.diff (get_expr_vars expr) (FDSet.of_list dont_touch)) in
721
  let extracted_sorts = List.map Z3.FuncDecl.get_range extracted_vars in
722
  let extracted_symbols = List.map Z3.FuncDecl.get_name extracted_vars in
723

    
724
  if !debug then (
725
    Format.eprintf "Declaring rule: %s with variables @[<v 0>@ [%a@ ]@]@ @."
726
      (Z3.Expr.to_string expr)
727
      (Utils.fprintf_list ~sep:",@ " (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))) (List.map horn_var_to_expr vars)
728
  )
729
    ;
730
  let expr = Z3.Quantifier.mk_forall_const
731
    !ctx  (* context *)
732
    (List.map horn_var_to_expr vars) (* TODO provide bounded variables as expr *)
733
    (* sorts           (\* sort list*\) *)
734
    (* symbols (\* symbol list *\) *)
735
    expr (* expression *)
736
    None (* quantifier weight, None means 1 *)
737
    [] (* pattern list ? *)
738
    [] (* ? *)
739
    None (* ? *)
740
    None (* ? *)
741
  in
742
  (* Format.eprintf "OK@.@?"; *)
743

    
744
  (*
745
    TODO: bizarre la declaration de INIT tout seul semble poser pb.
746
  *) 
747
  Z3.Fixedpoint.add_rule !fp
748
    (Z3.Quantifier.expr_of_quantifier expr)
749
    None
750

    
751
 
752
(********************************************************)
753
    
754
let machine_reset machines m =
755
  let locals = local_memory_vars machines m in
756
  
757
  (* print "x_m = x_c" for each local memory *)
758
  let mid_mem_def =
759
    List.map (fun v ->
760
      Z3.Boolean.mk_eq !ctx
761
	(horn_var_to_expr (rename_mid v))
762
	(horn_var_to_expr (rename_current v))
763
    ) locals
764
  in
765

    
766
  (* print "child_reset ( associated vars _ {c,m} )" for each subnode.
767
     Special treatment for _arrow: _first = true
768
  *)
769

    
770
  let reset_instances =
771
    
772
    List.map (fun (id, (n, _)) ->
773
      let name = node_name n in
774
      if name = "_arrow" then (
775
	Z3.Boolean.mk_eq !ctx
776
	  (
777
	    let vdecl = get_fdecl ((concat m.mname.node_id id) ^ "._arrow._first_m") in
778
	    Z3.Expr.mk_const_f !ctx vdecl
779
	  )
780
	  (Z3.Boolean.mk_true !ctx)
781
	  
782
      ) else (
783
	let machine_n = get_machine machines name in 
784
	
785
	Z3.Expr.mk_app
786
	  !ctx
787
	  (get_fdecl (name ^ "_reset"))
788
	  (List.map (horn_var_to_expr)
789
	     (idx::uid:: (* Additional vars: counters, uid *)
790
	      	(rename_machine_list (concat m.mname.node_id id) (reset_vars machines machine_n))
791
	  ))
792
	  
793
      )
794
    ) m.minstances
795
      
796
      
797
  in
798
  
799
  Z3.Boolean.mk_and !ctx (mid_mem_def @ reset_instances)
800
    
801
        
802

    
803
(*  TODO: empty list means true statement *)
804
let decl_machine machines m =
805
  if m.mname.node_id = Arrow.arrow_id then
806
    (* We don't do arrow function *)
807
    ()
808
  else
809
    begin
810
      let _ =
811
        List.map decl_var
812
      	  (
813
      	    (inout_vars machines m)@
814
      	      (rename_current_list (full_memory_vars machines m)) @
815
      	      (rename_mid_list (full_memory_vars machines m)) @
816
      	      (rename_next_list (full_memory_vars machines m)) @
817
      	      (rename_machine_list m.mname.node_id m.mstep.step_locals)
818
      	  )
819
      in
820
      if is_stateless m then
821
	begin
822
	  if !debug then 
823
	    Format.eprintf "Declaring a stateless machine: %s@." m.mname.node_id;
824

    
825
	  (* Declaring single predicate *)
826
	  let vars = inout_vars machines m in
827
	  let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
828
	  let _ = decl_rel (machine_stateless_name m.mname.node_id) vars_types in
829
	  
830
	  let horn_body, _ (* don't care for reset here *) =
831
	    instrs_to_expr
832
	      machines
833
	      ([] (* No reset info for stateless nodes *) )
834
	      m
835
	      m.mstep.step_instrs
836
	  in
837
	  let horn_head = 
838
	    Z3.Expr.mk_app
839
	      !ctx
840
	      (get_fdecl (machine_stateless_name m.mname.node_id))
841
	      (	List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
842
	  in
843
	  (* this line seems useless *)
844
	  let vars = idx::uid::vars@(rename_machine_list m.mname.node_id m.mstep.step_locals) in
845
	  (* Format.eprintf "useless Vars: %a@." (Utils.fprintf_list ~sep:"@ " Printers.pp_var) vars; *)
846
	  match m.mstep.step_asserts with
847
	  | [] ->
848
	     begin
849
	       (* Rule for single predicate : "; Stateless step rule @." *)
850
	       (*let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in*)
851
	       (* TODO clean code *)
852
	       (* Format.eprintf "used Vars: %a@." (Utils.fprintf_list ~sep:"@ " Printers.pp_var) vars; *)
853
	       add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
854
		 
855
	     end
856
	  | assertsl ->
857
	     begin
858
	       (*Rule for step "; Stateless step rule with Assertions @.";*)
859
	       let body_with_asserts =
860
		 Z3.Boolean.mk_and !ctx (horn_body :: List.map (horn_val_to_expr m.mname.node_id) assertsl)
861
	       in
862
	       let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in
863
	       add_rule vars (Z3.Boolean.mk_implies !ctx body_with_asserts horn_head)
864
	     end
865
	end
866
      else
867
	begin
868

    
869
	  (* Rule for reset *)
870

    
871
	  let vars = reset_vars machines m in
872
	  let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
873
	  let _ = decl_rel (machine_reset_name m.mname.node_id) vars_types in
874
	  let horn_reset_body = machine_reset machines m in	    
875
	  let horn_reset_head = 
876
	    Z3.Expr.mk_app
877
	      !ctx
878
	      (get_fdecl (machine_reset_name m.mname.node_id))
879
	      (	List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
880
	  in
881

    
882
	  
883
	  let _ =
884
	    add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx horn_reset_body horn_reset_head)
885
	      
886
	  in
887

    
888
	  (* Rule for step*)
889
	  let vars = step_vars machines m in
890
  	  let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
891
          let _ = decl_rel (machine_step_name m.mname.node_id) vars_types in
892
	  let horn_step_body, _ (* don't care for reset here *) =
893
	    instrs_to_expr
894
	      machines
895
	      []
896
	      m
897
	      m.mstep.step_instrs
898
	  in
899
	  let horn_step_head = 
900
	    Z3.Expr.mk_app
901
	      !ctx
902
	      (get_fdecl (machine_step_name m.mname.node_id))
903
	      (	List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
904
	  in
905
	  match m.mstep.step_asserts with
906
	  | [] ->
907
	     begin
908
	       (* Rule for single predicate *) 
909
	       let vars = (step_vars_c_m_x machines m) @(rename_machine_list m.mname.node_id m.mstep.step_locals) in
910
	       add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx horn_step_body horn_step_head)
911
		 
912
	     end
913
	  | assertsl ->
914
	     begin
915
	       (* Rule for step Assertions @.; *)
916
	       let body_with_asserts =
917
		 Z3.Boolean.mk_and !ctx
918
		   (horn_step_body :: List.map (horn_val_to_expr m.mname.node_id) assertsl)
919
	       in
920
	       let vars = (step_vars_c_m_x machines m) @(rename_machine_list m.mname.node_id m.mstep.step_locals) in
921
	       add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx body_with_asserts horn_step_head)
922
		 
923
	     end
924
     	       
925
	end
926
    end
927

    
928

    
929

    
930
(* Debug functions *)
931

    
932
let rec extract_expr_fds e =
933
  (* Format.eprintf "@[<v 2>Extracting fundecls from expr %s@ " *)
934
  (*   (Z3.Expr.to_string e); *)
935
  
936
  (* Removing quantifier is there are some *)
937
  let e = (* I didn't found a nicer way to do it than with an exception.  My
938
	     bad *)
939
    try
940
      let eq = Z3.Quantifier.quantifier_of_expr e in
941
      let e2 = Z3.Quantifier.get_body eq in
942
      (* Format.eprintf "Extracted quantifier body@ "; *)
943
      e2
944
	
945
    with _ -> Format.eprintf "No quantifier info@ "; e
946
  in
947
  let _ =
948
    try 
949
    (
950
      let fd = Z3.Expr.get_func_decl e in
951
      let fd_symbol = Z3.FuncDecl.get_name fd in
952
      let fd_name = Z3.Symbol.to_string fd_symbol in
953
      if not (Hashtbl.mem decls fd_name) then
954
	register_fdecl fd_name fd;
955
      (* Format.eprintf "fdecls (%s): %s@ " *)
956
      (* 	fd_name *)
957
      (* 	(Z3.FuncDecl.to_string fd); *)
958
      try
959
	(
960
	  let args = Z3.Expr.get_args e in
961
	  (* Format.eprintf "@[<v>@ "; *)
962
	  (* List.iter extract_expr_fds args; *)
963
	  (* Format.eprintf "@]@ "; *)
964
	  ()
965
	)
966
      with _ ->
967
	Format.eprintf "Impossible to extract fundecl args for expression %s@ "
968
	  (Z3.Expr.to_string e)
969
    )
970
  with _ ->
971
    Format.eprintf "Impossible to extract anything from expression %s@ "
972
      (Z3.Expr.to_string e)
973
  in
974
  (* Format.eprintf "@]@ " *)
975
  ()      
976

    
977
(* Local Variables: *)
978
(* compile-command:"make -C ../.." *)
979
(* End: *)