Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / tools / zustre / zustre_common.ml @ 58301109

History | View | Annotate | Download (29.2 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
exception UnknownFunction of (string * (Format.formatter -> unit))
41
(** Sorts
42

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

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

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

    
54

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

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

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

    
94

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

    
101
(** Func decls
102

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

    
107

    
108

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

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

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

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

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

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

    
170

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

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

    
180
(** Conversion functions
181

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

    
185
*)
186

    
187

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

    
192

    
193

    
194

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

    
222

    
223

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

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

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

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

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

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

    
328

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

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

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

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

    
353

    
354
    
355
  (* | _, [v1; v2] ->      Z3.Boolean.mk_and
356
   *      !ctx
357
   *      (val_to_expr v1)
358
   *      (val_to_expr v2)
359
   * 
360
   *      Format.fprintf fmt "(%s %a %a)" i val_to_exprr v1 val_to_expr v2 *)
361
  | _ -> (
362
    let msg fmt = Format.fprintf fmt
363
                    "internal error: zustre unkown function %s (nb args = %i)@."
364
                    i (List.length vl)
365
    in
366
    raise (UnknownFunction(i, msg))
367
  )
368

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

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

    
410
  (* Code specific for arrays *)
411
    
412
  | Power (v, n)  -> assert false
413
  | Var v    ->
414
     if is_memory m v then
415
       if Types.is_array_type v.var_type
416
       then assert false
417
       else horn_var_to_expr (rename_machine self ((if is_lhs then rename_next else rename_current) (* self *) v))
418
     
419
     else 
420
       horn_var_to_expr
421
         (rename_machine
422
            self
423
            v)
424
  | Fun (n, vl)   -> horn_basic_app n (horn_val_to_expr m self) vl
425

    
426
let no_reset_to_exprs machines m i =
427
  let (n,_) = List.assoc i m.minstances in
428
  let target_machine = List.find (fun m  -> m.mname.node_id = (Corelang.node_name n)) machines in
429

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

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

    
479
let instance_call_to_exprs machines reset_instances m i inputs outputs =
480
  let self = m.mname.node_id in
481

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

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

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

    
539
	| node_name_n ->
540
           let expr = 
541
             Z3.Expr.mk_app
542
               !ctx
543
               (get_fdecl (machine_step_name (node_name n)))
544
               ( (* Arguments are input, output, mid_mems, next_mems *)
545
		 idx_uid_inout @ List.map (horn_var_to_expr) (mid_mems@next_mems)
546
		    
547
               )
548
           in
549
           [expr]
550
      in
551

    
552
      reset_exprs@call_expr
553
    end
554
  with Not_found -> ( (* stateless node instance *)
555
    let (n,_) = List.assoc i m.mcalls in
556
    let expr = 
557
      Z3.Expr.mk_app
558
        !ctx
559
        (get_fdecl (machine_stateless_name (node_name n)))
560
        idx_uid_inout 	  (* Arguments are inputs, outputs *)
561
    in
562
    [expr]
563
  )
564

    
565

    
566
    
567
(* (\* Prints a [value] indexed by the suffix list [loop_vars] *\) *)
568
(* let rec value_suffix_to_expr self value = *)
569
(*  match value.value_desc with *)
570
(*  | Fun (n, vl)  ->  *)
571
(*     horn_basic_app n (horn_val_to_expr self) (value_suffix_to_expr self vl) *)
572
    
573
(*  |  _            -> *)
574
(*    horn_val_to_expr self value *)
575

    
576

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

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

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

    
643
      [e], branch_resets
644
	  
645
    in
646
    List.fold_left (fun (instrs, resets) b ->
647
      let b_instrs, b_resets = branch_to_expr b in
648
      instrs@b_instrs, resets@b_resets 
649
    ) ([], reset_instances) hl 
650

    
651
and instrs_to_expr machines reset_instances m instrs = 
652
  let instr_to_exprs rs i = instr_to_exprs machines rs m i in
653
  let e_list, rs = 
654
    match instrs with
655
    | [x] -> instr_to_exprs reset_instances x 
656
    | _::_ -> (* 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 *)
657
       
658
       List.fold_left (fun (exprs, rs) i -> 
659
         let exprs_i, rs_i = instr_to_exprs rs i in
660
         exprs@exprs_i, rs@rs_i
661
       )
662
         ([], reset_instances) instrs 
663
	 
664
	 
665
    | [] -> [], reset_instances
666
  in
667
  let e = 
668
    match e_list with
669
    | [e] -> e
670
    | [] -> Z3.Boolean.mk_true !ctx
671
    | _ -> Z3.Boolean.mk_and !ctx e_list
672
  in
673
  e, rs
674

    
675

    
676
(*********************************************************)
677

    
678
(* Quantifiying universally all occuring variables *)
679
let add_rule ?(dont_touch=[]) vars  expr =
680
  (* let fds = Z3.Expr.get_args expr in *)
681
  (* Format.eprintf "Expr %s: args: [%a]@." *)
682
  (*   (Z3.Expr.to_string expr) *)
683
  (*   (Utils.fprintf_list ~sep:", " (fun fmt e -> Format.pp_print_string fmt (Z3.Expr.to_string e))) fds; *)
684

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

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

    
751
  (*
752
    TODO: bizarre la declaration de INIT tout seul semble poser pb.
753
  *) 
754
  Z3.Fixedpoint.add_rule !fp
755
    (Z3.Quantifier.expr_of_quantifier expr)
756
    None
757

    
758
 
759
(********************************************************)
760
    
761
let machine_reset machines m =
762
  let locals = local_memory_vars machines m in
763
  
764
  (* print "x_m = x_c" for each local memory *)
765
  let mid_mem_def =
766
    List.map (fun v ->
767
      Z3.Boolean.mk_eq !ctx
768
	(horn_var_to_expr (rename_mid v))
769
	(horn_var_to_expr (rename_current v))
770
    ) locals
771
  in
772

    
773
  (* print "child_reset ( associated vars _ {c,m} )" for each subnode.
774
     Special treatment for _arrow: _first = true
775
  *)
776

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

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

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

    
876
	  (* Rule for reset *)
877

    
878
	  let vars = reset_vars machines m in
879
	  let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
880
	  let _ = decl_rel (machine_reset_name m.mname.node_id) vars_types in
881
	  let horn_reset_body = machine_reset machines m in	    
882
	  let horn_reset_head = 
883
	    Z3.Expr.mk_app
884
	      !ctx
885
	      (get_fdecl (machine_reset_name m.mname.node_id))
886
	      (	List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
887
	  in
888

    
889
	  
890
	  let _ =
891
	    add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx horn_reset_body horn_reset_head)
892
	      
893
	  in
894

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

    
935

    
936

    
937
(* Debug functions *)
938

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

    
984
(* Local Variables: *)
985
(* compile-command:"make -C ../.." *)
986
(* End: *)