-
Notifications
You must be signed in to change notification settings - Fork 14
/
precondition.ml
1673 lines (1573 loc) · 65.8 KB
/
precondition.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(***************************************************************************)
(* *)
(* Copyright (C) 2018/2019 The Charles Stark Draper Laboratory, Inc. *)
(* *)
(* This file is provided under the license found in the LICENSE file in *)
(* the top-level directory of this project. *)
(* *)
(* This work is funded in part by ONR/NAWC Contract N6833518C0107. Its *)
(* content does not necessarily reflect the position or policy of the US *)
(* Government and no official endorsement should be inferred. *)
(* *)
(***************************************************************************)
open !Core
open Bap.Std
open Graphlib.Std
open Bap_core_theory
open Utils.Option_let
include Self()
module Expr = Z3.Expr
module Arith = Z3.Arithmetic
module BV = Z3.BitVector
module Bool = Z3.Boolean
module Z3Array = Z3.Z3Array
module FuncDecl = Z3.FuncDecl
module Solver = Z3.Solver
module Env = Environment
module Constr = Constraint
exception Not_implemented of string
type hooks = {
assume_before : Constr.t list;
assume_after : Constr.t list;
verify_before : Constr.t list;
verify_after : Constr.t list;
}
let z3_expr_zero (ctx : Z3.context) (size : int) : Constr.z3_expr = BV.mk_numeral ctx "0" size
let z3_expr_one (ctx : Z3.context) (size : int) : Constr.z3_expr = BV.mk_numeral ctx "1" size
let binop ?(smtlib_compat = false) (ctx : Z3.context) (b : binop) :
Constr.z3_expr -> Constr.z3_expr -> Constr.z3_expr =
let open Bap.Std.Bil.Types in
let zero = z3_expr_zero ctx 1 in
let one = z3_expr_one ctx 1 in
match b with
| PLUS -> BV.mk_add ctx
| MINUS -> BV.mk_sub ctx
| TIMES -> BV.mk_mul ctx
| DIVIDE -> BV.mk_udiv ctx
| SDIVIDE -> BV.mk_sdiv ctx
| MOD -> BV.mk_urem ctx
| SMOD -> BV.mk_smod ctx
| LSHIFT -> BV.mk_shl ctx
| RSHIFT -> BV.mk_lshr ctx
| ARSHIFT -> BV.mk_ashr ctx
| AND -> BV.mk_and ctx
| OR -> BV.mk_or ctx
| XOR -> BV.mk_xor ctx
| EQ -> fun x y -> if smtlib_compat then (Bool.mk_ite ctx (Bool.mk_eq ctx x y) one zero)
else (BV.mk_not ctx @@ BV.mk_redor ctx @@ BV.mk_xor ctx x y)
| NEQ -> fun x y -> if smtlib_compat
then Bool.mk_ite ctx (Bool.mk_eq ctx x y) zero one
else BV.mk_redor ctx @@ BV.mk_xor ctx x y
| LT -> fun x y -> Bool.mk_ite ctx (BV.mk_ult ctx x y) one zero
| LE -> fun x y -> Bool.mk_ite ctx (BV.mk_ule ctx x y) one zero
| SLT -> fun x y -> Bool.mk_ite ctx (BV.mk_slt ctx x y) one zero
| SLE -> fun x y -> Bool.mk_ite ctx (BV.mk_sle ctx x y) one zero
let unop (ctx : Z3.context) (u : unop) : Constr.z3_expr -> Constr.z3_expr =
let open Bap.Std.Bil.Types in
match u with
| NEG -> BV.mk_neg ctx
| NOT -> BV.mk_not ctx
let cast (ctx : Z3.context) (cst : cast) (i : int) (x : Constr.z3_expr) : Constr.z3_expr =
assert (i > 0);
let size = x |> Expr.get_sort |> BV.get_size in
let open Bap.Std.Bil.Types in
match cst with
| UNSIGNED -> BV.mk_zero_ext ctx (i - size) x
| SIGNED -> BV.mk_sign_ext ctx (i - size) x
| HIGH -> BV.mk_extract ctx (size - 1) (size - i) x
| LOW -> BV.mk_extract ctx (i - 1) 0 x
(* Placeholder for inlining function calls, which will be substituted with [visit_sub]
at its point of definition. *)
let inline_func :
(Constr.t -> Env.t -> Tid.t -> Constr.t * Env.t) ref =
ref (fun _ _ _ -> assert false)
let load_z3_mem (ctx : Z3.context) ~word_size:word_size ~mem:(mem : Constr.z3_expr)
~addr:(addr : Constr.z3_expr) (endian : Bap.Std.endian) : Constr.z3_expr =
assert (Z3Array.is_array mem && mem |> Expr.get_sort
|> Z3Array.get_range
|> Z3.Sort.get_sort_kind
|> (function
| Z3enums.BV_SORT -> true
|_ -> false));
let m_size = mem |> Expr.get_sort |> Z3Array.get_range |> BV.get_size in
let addr_size = addr |> Expr.get_sort |> BV.get_size in
let nums_to_read = word_size / m_size in
debug "Creating load on Mem<%d,%d>, with target Imm<%d>%!" addr_size m_size word_size;
assert (nums_to_read > 0);
let rec read_list n addr reads =
if n = 0 then reads
else
(* TODO: handle overflow *)
let addr' = BV.mk_add ctx addr (z3_expr_one ctx addr_size) in
read_list (n-1) addr' (Z3Array.mk_select ctx mem addr :: reads)
in
let read = read_list nums_to_read addr [] in
let read_sorted =
match endian with
| BigEndian -> List.rev read
| LittleEndian -> read
in
List.reduce_exn read_sorted ~f:(BV.mk_concat ctx)
let store_z3_mem (ctx : Z3.context) ~word_size:word_size
~mem:(mem : Constr.z3_expr) ~addr:(addr : Constr.z3_expr) ~content:(e : Constr.z3_expr)
(endian : Bap.Std.endian) : Constr.z3_expr =
assert (Z3Array.is_array mem && mem |> Expr.get_sort
|> Z3Array.get_range
|> Z3.Sort.get_sort_kind
|> (function
| Z3enums.BV_SORT -> true
| _ -> false));
let m_size = mem |> Expr.get_sort |> Z3Array.get_range |> BV.get_size in
let addr_size = addr |> Expr.get_sort |> BV.get_size in
let nums_to_write = word_size / m_size in
let first_loc, next_loc =
match endian with
| BigEndian -> word_size - m_size, fun l -> l - m_size
| LittleEndian -> 0, fun l -> l + m_size
in
assert (nums_to_write > 0);
let rec store n loc addr mem =
if n = 0 then mem
else
begin
(* TODO: handle overflow *)
debug "Storing bits %d to %d at position %s%!"
loc (loc + m_size - 1) (Expr.to_string addr);
let e_chunk_n = BV.mk_extract ctx (loc + m_size - 1) loc e in
let mem' = Z3Array.mk_store ctx mem addr e_chunk_n in
let addr' = BV.mk_add ctx addr (z3_expr_one ctx addr_size) in
store (n-1) (next_loc loc) addr' mem'
end
in
debug "Creating store on Mem<%d,%d>, with target Imm<%d>%!" addr_size m_size word_size;
store nums_to_write first_loc addr mem
let bv_to_bool (bv : Constr.z3_expr) (ctx : Z3.context) (width : int) : Constr.z3_expr =
let zero = z3_expr_zero ctx width in
Bool.mk_not ctx (Bool.mk_eq ctx bv zero)
(* Sorts a list of [cond_type]s into a record which separates each hook into assumptions,
VCs, and whether these conditions should be added to the postcondition before or
after execution. *)
let mk_hooks (conds : Env.cond_type list) : hooks =
let hooks =
{ assume_before = []; assume_after = []; verify_before = []; verify_after = [] } in
List.fold conds ~init:hooks ~f:(fun hooks cond ->
match cond with
| Assume (BeforeExec c) ->
{ hooks with assume_before = Constr.mk_constr c :: hooks.assume_before }
| Assume (AfterExec c) ->
{ hooks with assume_after = Constr.mk_constr c :: hooks.assume_after }
| Verify (BeforeExec c) ->
{ hooks with verify_before = Constr.mk_constr c :: hooks.verify_before }
| Verify (AfterExec c) ->
{ hooks with verify_after = Constr.mk_constr c :: hooks.verify_after }
)
let hooks_to_string (h : hooks) : string =
Format.sprintf "VCs before exec:%s\nVCs after exec:%s\n \
Assumptions before exec:%s\nAssumptions after exec:%s\n%!"
(List.to_string ~f:Constr.to_string h.verify_before)
(List.to_string ~f:Constr.to_string h.verify_after)
(List.to_string ~f:Constr.to_string h.assume_before)
(List.to_string ~f:Constr.to_string h.assume_after)
let word_to_z3 (ctx : Z3.context) (w : Word.t) : Constr.z3_expr =
let fmt = Format.str_formatter in
Word.pp_dec fmt w;
let s = Format.flush_str_formatter () in
BV.mk_numeral ctx s (Word.bitwidth w)
let exp_to_z3 (exp : Exp.t) (env : Env.t) : Constr.z3_expr * hooks * Env.t =
let ctx = Env.get_context env in
let open Bap.Std.Bil.Types in
let rec exp_to_z3_body exp env : Constr.z3_expr * Env.t =
match exp with
| Load (mem, addr, endian, size) ->
debug "Visiting load: Mem:%s Addr:%s Size:%s%!"
(Exp.to_string mem) (Exp.to_string addr) (Size.to_string size);
let mem_val, env = exp_to_z3_body mem env in
let addr_val, env = exp_to_z3_body addr env in
load_z3_mem ctx ~word_size:(Size.in_bits size) ~mem:mem_val ~addr:addr_val endian, env
| Store (mem, addr, exp, endian, size) ->
debug "Visiting store: Mem:%s Addr:%s Exp:%s Size:%s%!"
(Exp.to_string mem) (Exp.to_string addr) (Exp.to_string exp) (Size.to_string size);
let mem_val, env = exp_to_z3_body mem env in
let addr_val, env = exp_to_z3_body addr env in
let exp_val, env = exp_to_z3_body exp env in
store_z3_mem ctx ~word_size:(Size.in_bits size)
~mem:mem_val ~addr:addr_val ~content:exp_val endian, env
| BinOp (bop, x, y) ->
debug "Visiting binop: %s %s %s%!"
(Exp.to_string x) (Bil.string_of_binop bop) (Exp.to_string y);
let get_size v = v |> Expr.get_sort |> BV.get_size in
let x_val, env = exp_to_z3_body x env in
let y_val, env = exp_to_z3_body y env in
(* In x86 decoding, it is possible to scale the address with a 2-bitwidth shift
of 0, 1, 2, or 3. However, Z3 requires requires the operands of a bit shift
to be of the same bitwidth. Here, we pad the operand with the smaller
bitwidth to match the bitwidth of the other operand. *)
let x_val, y_val =
match bop with
| LSHIFT | RSHIFT | ARSHIFT ->
let x_size = get_size x_val in
let y_size = get_size y_val in
if x_size > y_size then
x_val, BV.mk_zero_ext ctx (x_size - y_size) y_val
else if y_size > x_size then
BV.mk_zero_ext ctx (y_size - x_size) x_val, y_val
else
x_val, y_val
| _ -> x_val, y_val
in
assert (get_size x_val = get_size y_val);
let smtlib_compat = Env.get_smtlib_compat env in
binop ~smtlib_compat ctx bop x_val y_val, env
| UnOp (u, x) ->
debug "Visiting unop: %s %s%!" (Bil.string_of_unop u) (Exp.to_string x);
let x_val, env = exp_to_z3_body x env in
unop ctx u x_val, env
| Var v ->
debug "Visiting var: %s%!" (Var.to_string v);
Env.get_var env v
| Bil.Types.Int w ->
debug "Visiting int: %s%!" (Word.to_string w);
word_to_z3 ctx w, env
| Cast (cst, i, x) ->
debug "Visiting cast: %s from %d to %s%!"
(Bil.string_of_cast cst) i (Exp.to_string x);
let x_val, env = exp_to_z3_body x env in
cast ctx cst i x_val, env
| Let (v, exp, body) ->
debug "Visiting let %s = %s in %s%!"
(Var.to_string v) (Exp.to_string exp) (Exp.to_string body);
let exp_val, env = exp_to_z3_body exp env in
let old_val = Env.find_var env v in
let env' = Env.add_var env v exp_val in
let z3_expr, env = exp_to_z3_body body env' in
let env = Env.remove_var env v in
let env = match old_val with
| None -> env
| Some exp_val -> Env.add_var env v exp_val in
(z3_expr, env)
| Unknown (str, typ) ->
debug "Visiting unknown: %s Type:%s%!" str (Type.to_string typ);
Env.new_z3_expr env ~name:("unknown_" ^ str) typ, env
| Ite (cond, yes, no) ->
debug "Visiting ite: if %s\nthen %s\nelse %s%!"
(Exp.to_string cond) (Exp.to_string yes) (Exp.to_string no);
let cond_val, env = exp_to_z3_body cond env in
let cond_size = BV.get_size (Expr.get_sort cond_val) in
let yes_val, env = exp_to_z3_body yes env in
let no_val, env = exp_to_z3_body no env in
Bool.mk_ite ctx (bv_to_bool cond_val ctx cond_size) yes_val no_val, env
| Extract (high, low, exp) ->
debug "Visiting extract: High:%d Low:%d Exp:%s%!" high low (Exp.to_string exp);
let exp_val, env = exp_to_z3_body exp env in
BV.mk_extract ctx high low exp_val, env
| Concat (w1, w2) ->
debug "Visiting concat: %s ^ %s%!" (Exp.to_string w1) (Exp.to_string w2);
let w1_val, env = exp_to_z3_body w1 env in
let w2_val, env = exp_to_z3_body w2 env in
BV.mk_concat ctx w1_val w2_val, env
in
let exp_conds = Env.mk_exp_conds env exp in
let hooks = mk_hooks exp_conds in
let z3_exp, new_env = exp_to_z3_body exp env in
z3_exp, hooks, new_env
let typ_size (t : Type.t) : int =
match t with
| Bil.Types.Imm n -> n
| Bil.Types.Mem (_, s) -> Size.in_bits s
| Bil.Types.Unk ->
error "Unk type: Unable to obtain type size.%!";
failwith "typ_size: elt's type is not representable by Type.t"
let set_fun_called (post : Constr.t) (env : Env.t) (tid : Tid.t) : Constr.t =
let ctx = Env.get_context env in
let fun_name =
Env.get_called env tid
|> Option.value_exn ?here:None ?error:None ?message:None
|> Bool.mk_const_s ctx
in
Constr.substitute_one post fun_name (Bool.mk_true ctx)
(* FIXME: handle other architectures *)
let increment_stack_ptr (post : Constr.t) (env : Env.t) : Constr.t * Env.t =
let target = Env.get_target env in
if Env.is_x86 target then
begin
let sp, env = Env.get_sp env |> Env.get_var env in
let width = target |> Theory.Target.bits in
let addr_size = target |> Theory.Target.code_addr_size in
let addr_size = addr_size / Theory.Target.byte target in
let ctx = Env.get_context env in
let offset = BV.mk_numeral ctx (Int.to_string addr_size) width in
let z3_off = BV.mk_add ctx sp offset in
Constr.substitute_one post sp z3_off, env
end
else
post, env
let lookup_precond (tid: Bap.Std.Tid.t) (env: Env.t) (post: Constr.t) =
match Env.get_precondition env tid with
| Some pre -> pre
| None ->
info "Precondition for return %s not found!" (Tid.to_string tid);
post
(* Creates a Z3 function of the form func_ret_out_var(in_vars, ...) which represents
an output variable to a function call. It substitutes the original z3_expr
representing the output variable. *)
let subst_fun_outputs ?tid_name:(tid_name = "") ~inputs:(inputs : Var.t list)
~outputs:(outputs : Var.t list) (env : Env.t) (sub : Sub.t) (post : Constr.t)
: Constr.t * Env.t =
debug "Chaosing outputs for %s%!" (Sub.name sub);
let ctx = Env.get_context env in
let sub_name = Env.map_sub_name env (Sub.name sub) in
let inputs = List.map inputs
~f:(fun i ->
let input, _ = Env.get_var env i in
input)
in
let input_sorts = List.map inputs ~f:Expr.get_sort in
let outputs = List.map outputs
~f:(fun o ->
let tid_name = if (String.equal tid_name "") then "" else ("_" ^ tid_name) in
let name = Format.sprintf "%s%s_ret_%s" sub_name (tid_name) (Var.to_string o) in
let z3_v, _ = Env.get_var env o in
let func_decl = FuncDecl.mk_func_decl_s ctx name input_sorts (Expr.get_sort z3_v) in
let application = FuncDecl.apply func_decl inputs in
debug "\t%s%!" (Expr.to_string application);
(z3_v, application))
in
let subs_from, subs_to = List.unzip outputs in
let env = List.fold subs_to ~init:env ~f:(fun env sub_to ->
Env.add_call_pred env sub_to) in
Constr.substitute post subs_from subs_to, env
(* Gets the registers that were stored in the insn attribute as defined in
[Loader.registers]. *)
let get_registers (term : 'a term) =
let open KB.Syntax in
match Term.get_attr term Disasm.insn with
| None -> Var.Set.empty
| Some insn -> insn.$[Loader.registers]
(* Instructions with unknown semantics are lifted as intrinsic calls. The
target of these calls are not real subroutines, and we create a predicate
here rather than invoking function call handler. *)
let intrinsic_call (tid : Tid.t) (env : Env.t) (post : Constr.t)
(jmp : Jmp.t) : (Constr.t * Env.t) option =
let (let+) x f = Option.map x ~f in
let+ dst = Env.get_subs env |> Seq.find ~f:(fun s ->
Tid.equal (Term.tid s) tid &&
String.is_prefix (Sub.name s) ~prefix:"intrinsic:") in
let regs = Var.Set.to_list (get_registers jmp) in
subst_fun_outputs env dst post ~inputs:regs ~outputs:regs
let lookup_sub_handler (tid: Bap.Std.Tid.t) (env: Env.t) (post: Constr.t)
(jmp : Jmp.t) : Constr.t * Env.t =
match intrinsic_call tid env post jmp with
| Some handler -> handler
| None -> match Env.get_sub_handler env tid with
| Some (Summary compute_func) -> compute_func env post tid
| Some Inline -> !inline_func post env tid
| None -> failwith (Format.sprintf "Unable to find sub handler for %s"
(Tid.to_string tid))
let visit_call (call: Bap.Std.Call.t) (post : Constr.t) (env : Env.t)
(jmp : Jmp.t) : Constr.t * Env.t =
let target = Call.target call in
let return = Call.return call in
match target, return with
| Direct t_tid, Some (Indirect _) ->
warning "making direct call to %s with indirect return!\n%!"
(Tid.to_string t_tid);
post, env
| Indirect _, Some (Indirect _) ->
warning "making indirect call with indirect return!\n%!";
post, env
| Indirect t_exp, None ->
warning "Making an indirect call with expression %s with no return;
applying the default spec (do nothing)!\n%!" (Exp.to_string t_exp);
Env.get_indirect_handler env t_exp env post t_exp false
| Direct t_tid, None ->
debug "Call label %s with no return%!" (Label.to_string target);
lookup_sub_handler t_tid env post jmp
| Direct t_tid, Some (Direct r_tid) ->
let ret_pre = lookup_precond r_tid env post in
lookup_sub_handler t_tid env ret_pre jmp
| Indirect t_exp, Some (Direct r_tid) ->
warning "Making an indirect call with expression %s with return to tid %s;
incrementing the stack pointer!\n%!"
(Exp.to_string t_exp) (Tid.to_string r_tid);
let ret_pre = lookup_precond r_tid env post in
Env.get_indirect_handler env t_exp env ret_pre t_exp true
let var_of_arg_t (arg : Arg.t) : Var.t =
let vars = arg |> Arg.rhs |> Exp.free_vars in
assert (Var.Set.length vars = 1);
Var.Set.choose_exn vars
let is_amd64 tgt = Theory.Target.matches tgt "amd64"
let is_i386 tgt = Theory.Target.matches tgt "i386"
let is_arm tgt = Theory.Target.matches tgt "arm"
(* FIXME: use built-in BAP roles? *)
let input_regs (target : Theory.target) : Var.t list =
if is_amd64 target then
begin
let open X86_cpu.AMD64 in
(* r.(0) and r.(1) refer to registers R8 and R9 respectively.
Arguments are placed on the stack when they have a higher count than the
number of registers. We currently do not handle mem as an input because it
causes Z3 to slow down during evaluation. *)
info "[mem] is not included as an input to the function call.%!";
[rdi; rsi; rdx; rcx; r.(0); r.(1)]
end
else if is_i386 target then
begin
warning "In 32-bit x86, arguments are passed through the stack.%!";
[]
end
else if is_arm target then
begin
let open ARM.CPU in
[r0; r1; r2; r3; r12]
end
else
begin
warning "caller_saved_regs: input registers have not \
been implemented for %s." (Theory.Target.to_string target);
[]
end
let caller_saved_regs (target : Theory.target) : Var.t list =
if is_amd64 target then
begin
let open X86_cpu.AMD64 in
(* Obtains registers r8 - r11 from X86_cpu.AMD64.r. *)
let r = Array.to_list (Array.sub r ~pos:0 ~len:4) in
[rax; rcx; rdx; rsi; rdi] @ r
end
else if is_i386 target then
begin
let open X86_cpu.IA32 in
[rax; rcx; rdx]
end
else if is_arm target then
begin
let open ARM.CPU in
[r0; r1; r2; r3; r12]
end
else
begin
warning "caller_saved_regs: Caller-saved registers have not \
been implemented for %s." (Theory.Target.to_string target);
[]
end
let callee_saved_regs (target : Theory.target) : Var.t list =
if is_amd64 target then
begin
let open X86_cpu.AMD64 in
(* Obtains registers r12 - r15 from X86_cpu.AMD64.r. *)
let r = Array.to_list (Array.sub r ~pos:4 ~len:4) in
[rbx; rsp; rbp] @ r
end
else if is_i386 target then
begin
let open X86_cpu.IA32 in
[rbx; rdi; rsi; rsp; rbp]
end
else if is_arm target then
begin
let open ARM.CPU in
[r4; r5; r6; r7; r8; r9; r10; r11]
end
else
begin
warning "callee_saved_regs: Callee-saved registers have not \
been implemented for %s." (Theory.Target.to_string target);
[]
end
let rec vars_from_sub (env : Env.t) (t : Sub.t) : Var.Set.t =
let vars =
if Env.use_input_regs env then
env |> Env.get_target |> input_regs |> Var.Set.of_list
else
Var.Set.empty
in
let visitor =
(object inherit [Var.Set.t] Term.visitor
method! visit_arg arg vars =
Var.Set.add vars (var_of_arg_t arg)
method! visit_def def vars =
let vars = Var.Set.add vars (Def.lhs def) in
let vars = Var.Set.union vars (Def.free_vars def) in
vars
method! visit_jmp jmp vars =
(* If the jump is a call to a target that is to be inlined, visit and
collect the variables in the target. *)
let vars = match Jmp.kind jmp with
| Call call ->
begin
match Call.target call with
| Direct tid ->
begin
match Env.get_sub_handler env tid with
| Some Inline ->
let subs = Env.get_subs env in
let target = Seq.find_exn subs ~f:(fun s -> Tid.equal (Term.tid s) tid) in
Var.Set.union vars (vars_from_sub env target)
| _ -> vars
end
| Indirect _ -> vars
end
| _ -> vars
in
Var.Set.union vars (Jmp.free_vars jmp)
end)
in
visitor#visit_sub t vars
let get_vars (env : Env.t) (t : Sub.t) : Var.Set.t =
let gprs = Env.get_gprs env in
let mem = Var.Set.singleton (Env.get_mem env) in
let sp = Var.Set.singleton (Env.get_sp env) in
let sub_vars = vars_from_sub env t in
Var.Set.union_list [gprs; mem; sp; sub_vars]
let spec_verifier_error (sub : Sub.t) (_ : Theory.target) : Env.fun_spec option =
let is_verifier_error name = String.(
name = "__VERIFIER_error" ||
name = "__assert_fail")
in
if is_verifier_error (Sub.name sub) then
Some {
spec_name = "spec_verifier_error";
spec = Summary (fun env _ _ ->
let pre =
Env.get_context env
|> Bool.mk_false
|> Constr.mk_goal "assert_fail"
|> Constr.mk_constr
in
pre, env
)
}
else
None
let spec_verifier_assume (sub : Sub.t) (_ : Theory.target) : Env.fun_spec option =
if String.equal (Sub.name sub) "__VERIFIER_assume" then
Some {
spec_name = "spec_verifier_assume";
spec = Summary
(fun env post tid ->
let ctx = Env.get_context env in
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let args = Term.enum arg_t sub in
let is_input arg =
match Arg.intent arg with
| Some In | Some Both -> true
| _ -> false
in
let input =
match Seq.find args ~f:is_input with
| Some i -> i
| None -> failwith "Verifier headerfile must be specified with --api-path" in
let v = var_of_arg_t input in
let z3_v, env = Env.get_var env v in
let size = BV.get_size (Expr.get_sort z3_v) in
let assumption =
bv_to_bool z3_v ctx size
|> Constr.mk_goal (Format.sprintf "assume %s" (Expr.to_string z3_v))
|> Constr.mk_constr
in
Constr.mk_clause [assumption] [post], env)
}
else
None
let spec_verifier_nondet (no_chaos : string list) (sub : Sub.t)
(_ : Theory.target) : Env.fun_spec option =
let is_nondet name = String.(
(is_prefix name ~prefix:"__VERIFIER_nondet_")
|| (equal name "calloc")
|| (equal name "malloc"))
in
let no_chaos name = List.exists no_chaos ~f:(fun nc -> String.equal name nc) in
let sub_name = Sub.name sub in
if (is_nondet sub_name) && (not @@ no_chaos sub_name) then
Some {
spec_name = "spec_verifier_nondet";
spec = Summary
(fun env post tid ->
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let args = Term.enum arg_t sub in
let is_output arg =
match Arg.intent arg with
| Some Out | Some Both -> true
| _ -> false
in
let output =
match Seq.find args ~f:is_output with
| Some o -> o
| None -> failwith "Verifier headerfile must be specified with --api-path" in
let vars = output |> Bap.Std.Arg.rhs |> Exp.free_vars in
let name = Format.sprintf "%s_ret_%s" (Sub.name sub) in
Env.freshen ~name post env vars)
}
else
None
let spec_empty (sub : Sub.t) (_ : Theory.target) : Env.fun_spec option =
if (Seq.is_empty @@ Term.enum blk_t sub) then
Some {
spec_name = "spec_empty";
spec = Summary (fun env post _tid -> post, env)
}
else None
let spec_arg_terms (sub : Sub.t) (_ : Theory.target) : Env.fun_spec option =
let args = Term.enum arg_t sub in
if not (Seq.is_empty args) then
Some {
spec_name = "spec_arg_terms";
spec = Summary
(fun env post tid ->
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let inputs, outputs = Seq.fold args ~init:([], [])
~f:(fun (ins, outs) arg ->
let var = var_of_arg_t arg in
match Arg.intent arg with
| Some In -> var :: ins, outs
| Some Out -> ins, var :: outs
| Some Both -> var :: ins, var :: outs
| None -> ins, outs)
in
let inputs = if Env.use_input_regs env then inputs else [] in
subst_fun_outputs env sub post ~inputs:inputs ~outputs:outputs)
}
else
None
let spec_rax_out (sub : Sub.t) (target : Theory.target) : Env.fun_spec option =
(* Calling convention for x86 uses EAX as output register. x86_64 uses RAX. *)
let defs sub =
Term.enum blk_t sub
|> Seq.map ~f:(Term.enum def_t)
|> Seq.concat
in
let is_rax def =
let reg = Var.to_string (Def.lhs def) in
String.(reg = "RAX" || reg = "EAX")
in
if Seq.exists (defs sub) ~f:is_rax then
(* RAX is a register that is used in the subroutine *)
Some {
spec_name = "spec_rax_out";
spec = Summary
(fun env post tid ->
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let inputs = if Env.use_input_regs env then input_regs target else [] in
let rax = Seq.find_exn (defs sub) ~f:is_rax |> Def.lhs in
subst_fun_outputs env sub post ~inputs ~outputs:[rax])
}
else
None
let spec_chaos_rax (sub : Sub.t) (target : Theory.target) : Env.fun_spec option =
if is_amd64 target then
Some {
spec_name = "spec_chaos_rax";
spec = Summary
(fun env post tid ->
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let inputs = if Env.use_input_regs env then input_regs target else [] in
subst_fun_outputs env sub post ~inputs ~outputs:[X86_cpu.AMD64.rax])
}
else
None
let spec_chaos_caller_saved (sub : Sub.t) (target : Theory.target) : Env.fun_spec option =
Some {
spec_name = "spec_chaos_caller_saved";
spec = Summary
(fun env post tid ->
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let inputs = if Env.use_input_regs env then input_regs target else [] in
let regs = caller_saved_regs target in
subst_fun_outputs env sub post ~inputs ~outputs:regs)
}
let spec_afl_maybe_log (sub : Sub.t) (target : Theory.target) : Env.fun_spec option =
if String.equal (Sub.name sub) "__afl_maybe_log" then
begin
if is_amd64 target then
Some {
spec_name = "spec_afl_maybe_log";
spec = Summary
(fun env post tid ->
let post = set_fun_called post env tid in
let post, env = increment_stack_ptr post env in
let inputs = if Env.use_input_regs env then input_regs target else [] in
let outputs =
let open X86_cpu.AMD64 in
[rax; rcx; rdx]
in
subst_fun_outputs env sub post ~inputs ~outputs)
}
else
raise (Not_implemented "spec_afl_maybe_log: The spec for afl_maybe_log only \
supports x86_64.")
end
else
None
let spec_default (_ : Sub.t) (_ : Theory.target) : Env.fun_spec =
{
spec_name = "spec_default";
spec = Summary (fun env post tid ->
let post = set_fun_called post env tid in
increment_stack_ptr post env)
}
let spec_inline (to_inline : Sub.t Seq.t) (sub : Sub.t) (_ : Theory.target)
: Env.fun_spec option =
if Seq.mem to_inline sub ~equal:Sub.equal then
Some {
spec_name = "spec_inline";
spec = Inline
}
else
None
let indirect_spec_default : Env.indirect_spec =
(* NOTE we keep around exp for that point in the future
* when we can use it to determine the destination of the
* indirect call. *)
fun env post _exp has_return ->
if has_return then increment_stack_ptr post env
else post, env
let jmp_spec_default : Env.jmp_spec =
fun _ _ _ _ -> None
let int_spec_default : Env.int_spec =
fun env post _ ->
error "Currently we do not handle system calls%!";
post, env
let num_unroll : int ref = ref 5
let default_stack_range : Env.mem_range = {
base_addr = 0x40000000;
size = 0x800000
}
(* TODO: The default data section range should not be hardcoded as it currently is.
We should use [brk] to determine this. *)
let default_data_section_range : Env.mem_range = {
base_addr = 0x000000;
size = 0x800000
}
(* Determines the condition for taking a jump, and uses it to generate the jump
expression's precondition based off of the postcondition and the
precondition of the jump's target. *)
let conditional_jmp (jmp : Jmp.t) (env : Env.t) (target_pre : Constr.t)
(post : Constr.t) : Constr.t * Env.t =
let ctx = Env.get_context env in
let cond = Jmp.cond jmp in
let cond_val, hooks, env = exp_to_z3 cond env in
debug "\n\nJump when %s:\n%s\n%!"
(Expr.to_string cond_val) (hooks_to_string hooks);
let cond_size = BV.get_size (Expr.get_sort cond_val) in
let false_cond = Bool.mk_eq ctx cond_val (z3_expr_zero ctx cond_size) in
let is_unconditional =
match cond with
| Bil.Types.Int w -> Word.is_one w
| _ -> false
in
let ite =
if is_unconditional then
target_pre
else
Constr.mk_ite jmp (Bool.mk_not ctx false_cond) target_pre post
in
(* If we add a PC variable, we should separate the befores and afters
similarly to how we did in visit_def *)
let vcs = hooks.verify_before @ hooks.verify_after in
let assume = hooks.assume_before @ hooks.assume_after in
let post = ite :: vcs in
Constr.mk_clause assume post, env
let visit_jmp (env : Env.t) (post : Constr.t) (jmp : Jmp.t) : Constr.t * Env.t =
let jmp_spec = Env.get_jmp_handler env in
match jmp_spec env post (Term.tid jmp) jmp with
| Some p_env -> p_env
| None ->
let target_pre, env =
match Jmp.kind jmp with
| Goto l ->
begin
match l with
| Direct tid ->
begin
debug "Goto direct label: %s%!" (Label.to_string l);
match Env.get_precondition env tid with
| Some pre -> pre, env
(* We always hit this point when finish a loop unrolling *)
| None ->
error "Precondition for node %s not found!" (Tid.to_string tid);
failwith ("Error in visit_jmp: \
The loop handler should have added the precondition for the node");
end
(* TODO: evaluate the indirect jump and
enumerate the possible concrete values, relate to tids
(probably tough...) *)
| Indirect _ ->
warning "Making an indirect jump, using the default postcondition!\n%!";
post, env
end
| Call call -> visit_call call post env jmp
(* TODO: do something here? *)
| Ret l ->
debug "Return to: %s%!" (Label.to_string l);
post, env
(* FIXME: do something here *)
| Int (i, tid) ->
debug "Interrupt %d with return to %s%!" i (Tid.to_string tid);
let ret_pre = Env.get_precondition env tid |>
Option.value_exn ?here:None ?error:None ?message:None in
let handler = Env.get_int_handler env in
handler env ret_pre i
in
conditional_jmp jmp env target_pre post
let visit_elt (env : Env.t) (post : Constr.t) (elt : Blk.elt) : Constr.t * Env.t =
match elt with
| `Def def ->
let var = Def.lhs def in
let rhs = Def.rhs def in
let rhs_exp, hooks, env = exp_to_z3 rhs env in
let z3_var, env = Env.get_var env var in
debug "Visiting def:\nlhs = %s : <%d> rhs = %s : <%d>%!"
(Expr.to_string z3_var) (var |> Var.typ |> typ_size)
(Expr.to_string rhs_exp) (rhs |> Type.infer_exn |> typ_size);
(* Adding the specified assumptions and VCs to the postcondition before applying
the substitution. *)
let post = post :: hooks.verify_before in
let post = Constr.mk_clause hooks.assume_before post in
let post = Constr.substitute_one post z3_var rhs_exp in
(* Adding the specified assumptions and VCs to the postcondition after applying
the substitution. *)
let post = post :: hooks.verify_after in
let post = Constr.mk_clause hooks.assume_after post in
post, Env.add_var env var z3_var
| `Jmp jmp ->
visit_jmp env post jmp
| `Phi _ ->
error "We do not currently handle Phi nodes.\n%!";
raise (Not_implemented "visit_elt: case `Phi(phi) not implemented")
let visit_block (env : Env.t) (post : Constr.t) (blk : Blk.t) : Constr.t * Env.t =
debug "Visiting block:\n%s%!" (Blk.to_string blk);
let compute_pre b =
Seq.fold b ~init:(post, env) ~f:(fun (pre, env) a -> visit_elt env pre a)
in
let pre, env = blk |> Blk.elts ~rev:true |> compute_pre in
(pre, Env.add_precond env (Term.tid blk) pre)
(* Returns [true] if the node is not reachable from the start of the graph.
This is used to prune non-reachable subgraphs from the DFS. *)
let unreachable_from_start (graph : Graphs.Ir.t) (start : Graphs.Ir.Node.t)
(node : Graphs.Ir.Node.t) : bool =
not (Graphlib.is_reachable (module Graphs.Ir) graph start node)
(* If you skip a node for which another node needs the prcondition, this
function may fail. *)
let visit_graph (env : Env.t) (post : Constr.t)
~(start : Graphs.Ir.Node.t) ~(skip_node : Graphs.Ir.Node.t -> bool)
(g : Graphs.Ir.t) : Constr.t * Env.t =
let module G = Graphs.Ir in
let module Filtered_graph = (val Graphlib.filtered (module G) ~skip_node ()) in
let leave_node _ n (_, env) =
let b = G.Node.label n in
visit_block env post b in
(* This function is the identity on forward & cross edges, and
invokes loop handling code on back edges *)
let enter_edge kind e (_, env) : Constr.t * Env.t =
match kind with
| `Back ->
begin
let src = G.Edge.src e in
let dst = G.Edge.dst e in
debug "Entering back edge from\n%sto\n%s\n%!"
(G.Node.to_string src) (G.Node.to_string dst);
let tid = dst |> G.Node.label |> Term.tid in
match Env.get_precondition env tid with
| Some pre -> pre, env
| None ->
let handler = Env.get_loop_handler env in
post, handler env post ~start:dst g
end
| _ ->
(* We return postcondition for the entire graph rather than the
postcondition for a single block. *)
post, env
in
Graphlib.depth_first_search (module Filtered_graph)
~enter_edge:enter_edge ~start:start ~leave_node:leave_node ~init:(post, env)
g
(* BAP currently doesn't have a way to determine that exit does not return.
This function removes the backedge after the call to exit. *)
let filter (env : Env.t) (calls : string list) (cfg : Graphs.Ir.t) : Graphs.Ir.t =
let enter_edge kind e cfg =
match kind with
| `Back -> begin
let elts =
e
|> Graphs.Ir.Edge.src
|> Graphs.Ir.Node.label
|> Blk.elts ~rev:true
in
let call_target = Seq.find_map elts ~f:(function
| `Jmp j -> begin
match Jmp.kind j with
| Call c -> begin
match Call.target c with
| Direct tid -> begin
match Env.get_sub_name env tid with
| Some target -> List.find calls ~f:(String.equal target)
| None -> None
end
| _ -> None
end
| _ -> None
end
| _ -> None)
in
match call_target with
| Some c ->
info "Removing the back edge from the return from %s" c;
Graphs.Ir.Edge.remove e cfg
| None -> cfg
end
| _ -> cfg
in
Graphlib.depth_first_search (module Graphs.Ir) ~enter_edge:enter_edge ~init:cfg cfg
let visit_sub (env : Env.t) (post : Constr.t) (sub : Sub.t) : Constr.t * Env.t =
let sub_name = (Sub.to_string sub) in
debug "Visiting sub:\n%s%!" sub_name;
let pre, env' =
if (Seq.is_empty @@ Term.enum blk_t sub)
then
(
warning "encountered empty subroutine %s%!" sub_name;
(post, env)
)
else
let cfg = sub |> Sub.to_cfg |> filter env ["exit"; "err"] in
let start = Term.first blk_t sub
|> Option.value_exn ?here:None ?error:None ?message:None
|> Graphs.Ir.Node.create in