From 9b0002f2fc06c89324b2cb57ff1008e492f60c51 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 23 Oct 2024 15:11:26 +0200 Subject: [PATCH 001/111] initial tests --- src/analyses/bitfield.ml | 154 ++++++++++++++++++++++++++ tests/regression/01-cpa/76-bitfield.c | 25 +++++ 2 files changed, 179 insertions(+) create mode 100644 src/analyses/bitfield.ml create mode 100644 tests/regression/01-cpa/76-bitfield.c diff --git a/src/analyses/bitfield.ml b/src/analyses/bitfield.ml new file mode 100644 index 0000000000..3ab8ff96eb --- /dev/null +++ b/src/analyses/bitfield.ml @@ -0,0 +1,154 @@ +(** Simplest possible analysis with unit domain ([unit]). *) + +open GoblintCil +open Analyses + + +module Bitfield = struct + + type t = int * int + + let equal (z1,o1) (z2,o2) = z1 = z2 && o1 = o2 + let hash (z,o) = 23 * z + 31 * o + let compare (z1,o1) (z2,o2) = + match compare z1 z2 with + | 0 -> compare o1 o2 + | c -> c + + let show (z,o) = Printf.sprintf "Bitfield{z:%x,o:%x}" z o + let pretty () (z,o) = Pretty.dprintf "Bitfield{z:%x,o:%x}" z o + let printXml out(z,o) = () (* TODO *) + + let name () = "Bitfield" + + let to_yojson (z,o) = + `Assoc [ + ("zeros", `Int z); + ("ones", `Int o) + ] + + let tag (z,o) = Hashtbl.hash (z,o) + let arbitrary () = QCheck.pair QCheck.int QCheck.int + let relift x = x + + let leq (z1,o1) (z2,o2) = + (z1 land (lnot z2)) = 0 && (o1 land (lnot o2)) = 0 + + let join (z1,o1) (z2,o2) = + (z1 lor z2, o1 lor o2) + + let meet (z1,o1) (z2,o2) = + (z1 land z2, o1 land o2) + + let widen (z1,o1) (z2,o2) = + let z_unstable = z2 land (lnot z1) in + let o_unstable = o2 land (lnot o1) in + if z_unstable = 0 && o_unstable = 0 then + (z2, o2) + else + (-1, -1) + + let narrow = meet + + let pretty_diff () ((z1,o1),(z2,o2)) = + Pretty.dprintf "Bitfield: (%x,%x) not leq (%x,%x)" z1 o1 z2 o2 + + + let from_ints (z:int) (o:int) : t = (z,o) + + let top () : t = (-1, -1) + let bot () : t = (0, 0) + let is_top (e:t) = e = top () + let is_bot (e:t) = e = bot () +end + + + +(* module Spec : Analyses.MCPSpec with module D = Lattice.Unit and module C = Printable.Unit and type marshal = unit = *) +(* No signature so others can override module G *) +module Spec = +struct + include Analyses.DefaultSpec + + module B = Bitfield + + let name () = "bitfield" + module D = MapDomain.MapBot (Basetype.Variables) (B) + include Analyses.ValueContexts(D) + + + module I = IntDomain.Flattened + + + let is_integer_var (v: varinfo) = + match v.vtype with + | TInt _ -> true + | _ -> false + + + let get_local = function + | Var v, NoOffset when is_integer_var v && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) + | _, _ -> None + + let rec eval (state : D.t) (e: exp) = + match e with + | Const c -> (match c with + | CInt (i,_,_) -> + (try I.of_int (Z.to_int64 i) with Z.Overflow -> I.top ()) + (* Our underlying int domain here can not deal with values that do not fit into int64 *) + (* Use Z.to_int64 instead of Cilint.int64_of_cilint to get exception instead of silent wrap-around *) + | _ -> I.top () + ) + | BinOp (PlusA, e1, e2, t) -> ( + let v1 = eval state e1 in + let v2 = eval state e2 in + I.add v1 v2 + ) + | _ -> I.top () + + + (* Map of integers variables to our signs lattice. *) + (* transfer functions *) + let assign ctx (lval:lval) (rval:exp) : D.t = + print_endline "assign"; + + let d = ctx.local in + match lval with + | (Var x, NoOffset) when not x.vaddrof -> + (* Convert the raw tuple to a proper Bitfield.t value *) + D.add x (B.from_ints (lnot 0) ( lnot 0)) d + | _ -> d + + let branch ctx (exp:exp) (tv:bool) : D.t = + print_endline "branch"; + ctx.local + + let body ctx (f:fundec) : D.t = + print_endline "body"; + ctx.local + + let return ctx (exp:exp option) (f:fundec) : D.t = + print_endline "return"; + ctx.local + + let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + print_endline "enter"; + [ctx.local, ctx.local] + + let combine_env ctx lval fexp f args fc au f_ask = + au + + let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + ctx.local + + let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + ctx.local + + let startstate v = D.bot () + let threadenter ctx ~multiple lval f args = [D.top ()] + let threadspawn ctx ~multiple lval f args fctx = ctx.local + let exitstate v = D.top () +end + +let _ = + MCP.register_analysis (module Spec : MCPSpec) diff --git a/tests/regression/01-cpa/76-bitfield.c b/tests/regression/01-cpa/76-bitfield.c new file mode 100644 index 0000000000..aca9ab28dc --- /dev/null +++ b/tests/regression/01-cpa/76-bitfield.c @@ -0,0 +1,25 @@ +#include +#include +#include + +#define ANY_ERROR 5 // 5 +int main() { + + int testvar=11; + + int state; + int r = rand() % 3; // {r 7→ [0; 2],state 7→ [MIN INT; MAX INT]} + switch (r) { + case 0: + state = 0; /* 0 */ + break; + case 1: + state = 8; /* 8 */ + break; + default: + state = 10; /* 10 */ + break; + } + // {r 7→ [0; 2],state 7→ [0; 10]} + assert((state & ANY_ERROR) == 0); +} From 582630cb1b8872fe3d65d33f9d3bc46c2e7d6395 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 23 Oct 2024 19:07:44 +0200 Subject: [PATCH 002/111] implement first bad solution --- src/analyses/bitfield.ml | 149 +++++++++++++++++++++++++++------------ 1 file changed, 103 insertions(+), 46 deletions(-) diff --git a/src/analyses/bitfield.ml b/src/analyses/bitfield.ml index 3ab8ff96eb..7b53d2c647 100644 --- a/src/analyses/bitfield.ml +++ b/src/analyses/bitfield.ml @@ -4,60 +4,72 @@ open GoblintCil open Analyses -module Bitfield = struct +module Bitfield= struct + module I = IntDomain.Flattened + + type t = I.t * I.t + +(* abstract operators from the paper *) + + let of_int (z:Z.t) : t = (I.lognot @@ I.of_int (Z.to_int64 z), I.of_int (Z.to_int64 z)) + + let logneg (p:t) :t = let (z,o) = p in (o,z) + + let logand (p1:t) (p2:t) :t = let (z1,o1) = p1 in let (z2,o2) = p2 in (I.logor z1 z2, I.logand o1 o2) + + let logor (p1:t) (p2:t) :t = let (z1,o1) = p1 in let (z2,o2) = p2 in (I.logand z1 z2, I.logor o1 o2) + + let logxor (p1:t) (p2:t) :t = let (z1,o1) = p1 in let (z2,o2) = p2 in (I.logor (I.logand z1 (I.lognot o2)) (I.logand (I.lognot o1) o2), I.logor (I.logand o1 (I.lognot o2)) (I.logand (I.lognot o1) o2)) + + let logshiftleft (p1:t) (p2:t) :t = failwith "Not implemented" + + let logshiftright (p1:t) (p2:t) :t = failwith "Not implemented" + + + let join (z1,o1) (z2,o2) = + (I.logor z1 z2, I.logor o1 o2) + + let meet (z1,o1) (z2,o2) = let nabla x y= (if x = I.logor x y then y else (I.of_int (Z.to_int64 (Z.minus_one) ))) in + (nabla z1 z2, nabla o1 o2) + + (* todo wrap *) - type t = int * int let equal (z1,o1) (z2,o2) = z1 = z2 && o1 = o2 - let hash (z,o) = 23 * z + 31 * o + let hash (z,o) = I.hash z + 31 * I.hash o let compare (z1,o1) (z2,o2) = match compare z1 z2 with | 0 -> compare o1 o2 | c -> c - let show (z,o) = Printf.sprintf "Bitfield{z:%x,o:%x}" z o - let pretty () (z,o) = Pretty.dprintf "Bitfield{z:%x,o:%x}" z o - let printXml out(z,o) = () (* TODO *) + let show (z,o) = Printf.sprintf "Bitfield{z:%s,o:%s}" (I.show z) (I.show o) + + let pretty () (z,o) = Pretty.dprintf "Bitfield{z:%s,o:%s}" (I.show z) (I.show o) + let printXml out(z,o) = BatPrintf.fprintf out "%a%a" I.printXml z I.printXml o let name () = "Bitfield" - let to_yojson (z,o) = - `Assoc [ - ("zeros", `Int z); - ("ones", `Int o) - ] + let to_yojson (z,o) = I.to_yojson z (*TODO*) + let tag (z,o) = Hashtbl.hash (z,o) - let arbitrary () = QCheck.pair QCheck.int QCheck.int + let arbitrary () = QCheck.pair (I.arbitrary ()) (I.arbitrary ()) let relift x = x - let leq (z1,o1) (z2,o2) = - (z1 land (lnot z2)) = 0 && (o1 land (lnot o2)) = 0 - - let join (z1,o1) (z2,o2) = - (z1 lor z2, o1 lor o2) + let leq (z1,o1) (z2,o2) = I.leq z1 z2 && I.leq o1 o2 - let meet (z1,o1) (z2,o2) = - (z1 land z2, o1 land o2) - let widen (z1,o1) (z2,o2) = - let z_unstable = z2 land (lnot z1) in - let o_unstable = o2 land (lnot o1) in - if z_unstable = 0 && o_unstable = 0 then - (z2, o2) - else - (-1, -1) + let widen (z1,o1) (z2,o2) = if I.leq z1 z2 && I.leq o1 o2 then (z2, o2) else (I.top (), I.top ()) let narrow = meet let pretty_diff () ((z1,o1),(z2,o2)) = - Pretty.dprintf "Bitfield: (%x,%x) not leq (%x,%x)" z1 o1 z2 o2 + Pretty.dprintf "Bitfield: (%s,%s) not leq (%s,%s)" (I.show z1) (I.show o1) (I.show z2) (I.show o2) - let from_ints (z:int) (o:int) : t = (z,o) - let top () : t = (-1, -1) - let bot () : t = (0, 0) + let top () : t = (I.of_int (Z.to_int64 (Z.minus_one)), I.of_int (Z.to_int64 (Z.minus_one))) + let bot () : t = (I.of_int (Z.to_int64 Z.zero), I.of_int (Z.to_int64 Z.zero)) let is_top (e:t) = e = top () let is_bot (e:t) = e = bot () end @@ -77,8 +89,6 @@ struct include Analyses.ValueContexts(D) - module I = IntDomain.Flattened - let is_integer_var (v: varinfo) = match v.vtype with @@ -94,17 +104,17 @@ struct match e with | Const c -> (match c with | CInt (i,_,_) -> - (try I.of_int (Z.to_int64 i) with Z.Overflow -> I.top ()) + (try B.of_int i with Z.Overflow -> B.top ()) (* Our underlying int domain here can not deal with values that do not fit into int64 *) (* Use Z.to_int64 instead of Cilint.int64_of_cilint to get exception instead of silent wrap-around *) - | _ -> I.top () - ) - | BinOp (PlusA, e1, e2, t) -> ( - let v1 = eval state e1 in - let v2 = eval state e2 in - I.add v1 v2 + | _ -> B.top () + + + ) - | _ -> I.top () + | Lval (Var x, NoOffset) when is_integer_var x && not (x.vglob || x.vaddrof) -> + (try D.find x state with Not_found -> B.top ()) + | _ -> B.top () (* Map of integers variables to our signs lattice. *) @@ -114,14 +124,28 @@ struct let d = ctx.local in match lval with - | (Var x, NoOffset) when not x.vaddrof -> + | (Var x, NoOffset) -> (* Convert the raw tuple to a proper Bitfield.t value *) - D.add x (B.from_ints (lnot 0) ( lnot 0)) d + let v = eval d rval in + D.add x v d | _ -> d - let branch ctx (exp:exp) (tv:bool) : D.t = - print_endline "branch"; - ctx.local + let branch ctx (exp:exp) (tv:bool) : D.t = + print_endline "branch"; + let d = ctx.local in + match exp with + | BinOp (Eq, e1, e2, _) -> + (match e1, e2 with + | Lval (Var x, NoOffset), Const (CInt (i,_,_)) when is_integer_var x && not (x.vglob || x.vaddrof) -> + let v = eval d e2 in + if tv then + D.add x v d else + D.add x (B.logneg v) d + | _ -> d + ) + + | _ -> d + let body ctx (f:fundec) : D.t = print_endline "body"; @@ -135,14 +159,47 @@ struct print_endline "enter"; [ctx.local, ctx.local] + + let assert_holds (d: D.t) (e:exp) = + print_endline "assert_holds"; + match e with + | BinOp (Eq, e1, e2, _) -> + (match e1, e2 with + | BinOp (BAnd, a,b,_), Const (CInt (i,_,_)) -> + let pl=eval d a in + let pr=eval d b in + let and_result=B.logand pl pr in + B.equal and_result (B.of_int i) + | _ -> false + ) +| _ -> false + + +let query ctx (type a) (q: a Queries.t): a Queries.result = + print_endline "query"; + let open Queries in + match q with + | EvalInt e when assert_holds ctx.local e -> + let ik = Cilfacade.get_ikind_exp e in + ID.of_bool ik true + | _ -> Result.top q + + let combine_env ctx lval fexp f args fc au f_ask = + print_endline "combine_env"; au let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + print_endline "combine_assign"; ctx.local let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - ctx.local + let d = ctx.local in + match lval with + | Some (Var x, NoOffset) -> D.add x( B.top ()) d + | _ -> d + + let startstate v = D.bot () let threadenter ctx ~multiple lval f args = [D.top ()] From 3042aaecefa168c19b3b7b3c6ef71bff0f32fd1c Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Sun, 27 Oct 2024 18:09:22 +0100 Subject: [PATCH 003/111] begin int domain rewrite to include bitfield --- src/cdomain/value/cdomains/intDomain.ml | 651 +++++++++++++++++++++--- src/cdomain/value/util/precisionUtil.ml | 19 +- src/config/options.schema.json | 13 + 3 files changed, 620 insertions(+), 63 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index e50b3f26cc..a67210adb7 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -15,6 +15,148 @@ exception ArithmeticOnIntegerBot of string +(* Custom Tuple6 as Batteries only provides up to Tuple5 *) +module Tuple6 = struct + type ('a,'b,'c,'d,'e,'f) t = 'a * 'b * 'c * 'd * 'e * 'f + + type 'a enumerable = 'a * 'a * 'a * 'a * 'a * 'a + + let make a b c d e f= (a, b, c, d, e, f) + + let first (a,_,_,_,_, _) = a + let second (_,b,_,_,_, _) = b + let third (_,_,c,_,_, _) = c + let fourth (_,_,_,d,_, _) = d + let fifth (_,_,_,_,e, _) = e + let sixth (_,_,_,_,_, f) = f + + let map f1 f2 f3 f4 f5 f6 (a,b,c,d,e,f) = + let a = f1 a in + let b = f2 b in + let c = f3 c in + let d = f4 d in + let e = f5 e in + let f = f6 f in + (a, b, c, d, e, f) + + let mapn fn (a,b,c,d,e,f) = + let a = fn a in + let b = fn b in + let c = fn c in + let d = fn d in + let e = fn e in + let f = fn f in + (a, b, c, d, e, f) + + let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) + let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) + let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) + let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) + let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) + let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) + + + + + let curry fn a b c d e f= fn (a,b,c,d,e,f) + let uncurry fn (a,b,c,d,e,f) = fn a b c d e f + + let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) + + let of_enum e = match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some a -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some b -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some c -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some d -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some e -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some f -> (a,b,c,d,e,f) + + let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e print_f out (a,b,c,d,e,f) = + BatIO.nwrite out first; + print_a out a; + BatIO.nwrite out sep; + print_b out b; + BatIO.nwrite out sep; + print_c out c; + BatIO.nwrite out sep; + print_d out d; + BatIO.nwrite out sep; + print_e out e; + BatIO.nwrite out sep; + print_f out f + BatIO.nwrite out last + + + let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = + print ~first ~sep ~last printer printer printer printer printer out pair + + let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) ?(cmp6=Pervasives.compare) (a1,a2,a3,a4,a5,a6) (b1,b2,b3,b4,b5,b6) = + let c1 = cmp1 a1 b1 in + if c1 <> 0 then c1 else + let c2 = cmp2 a2 b2 in + if c2 <> 0 then c2 else + let c3 = cmp3 a3 b3 in + if c3 <> 0 then c3 else + let c4 = cmp4 a4 b4 in + if c4 <> 0 then c4 else + let c5 = cmp5 a5 b5 in + if c5 <> 0 then c5 else + cmp5 a6 b6 + + open BatOrd + let eq eq1 eq2 eq3 eq4 eq5 eq6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + bin_eq eq1 t1 t1' + (bin_eq eq2 t2 t2' + (bin_eq eq3 t3 t3' + (bin_eq eq4 t4 t4' + (bin_eq eq5 t5 t5' eq6)))) t6 t6' + + let ord ord1 ord2 ord3 ord4 ord5 ord6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + bin_ord ord1 t1 t1' + (bin_ord ord2 t2 t2' + (bin_ord ord3 t3 t3' + (bin_ord ord4 t4 t4' + (bin_ord ord5 t5 t5' ord6)))) t6 t6' + + let comp comp1 comp2 comp3 comp4 comp5 comp6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + let c1 = comp1 t1 t1' in + if c1 <> 0 then c1 else + let c2 = comp2 t2 t2' in + if c2 <> 0 then c2 else + let c3 = comp3 t3 t3' in + if c3 <> 0 then c3 else + let c4 = comp4 t4 t4' in + if c4 <> 0 then c4 else + let c5 = comp5 t5 t5' in + if c5 <> 0 then c5 else + comp6 t6 t6' + + module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let eq = eq A.eq B.eq C.eq D.eq E.eq F.eq + end + + module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord ) (F : Ord) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let ord = ord A.ord B.ord C.ord D.ord E.ord F.ord + end + + module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp ) (F : Comp) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let compare = comp A.compare B.compare C.compare D.compare E.compare F.compare + end +end + + (** Define records that hold mutable variables representing different Configuration values. * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) @@ -1047,6 +1189,380 @@ struct let project ik p t = t end + + +(* BitField arithmetic, without any overflow handling etc. *) +module BitFieldArith (Ints_t : IntOps.IntOps) = struct + + let of_int (z,o) = (Ints_t.lognot @@ Ints_t.of_int z, Ints_t.of_int o) + + let logneg (z,o) = (o,z) + + let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) + + let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) + + let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 (Ints_t.lognot o2)) (Ints_t.logand (Ints_t.lognot o1) o2), + Ints_t.logor (Ints_t.logand o1 (Ints_t.lognot o2)) (Ints_t.logand (Ints_t.lognot o1) o2)) + let shift_left (z,o) n = failwith "Not implemented" + + let shift_right (z,o) n = failwith "Not implemented" + + let to_int (x1, x2) = + if Ints_t.equal x1 x2 then Some x1 else None + +end + + + +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = + struct + let name () = "bitfield" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] + module BArith = BitFieldArith (Ints_t) + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = Some (Ints_t.lognot (Ints_t.zero), Ints_t.zero) + let top_of ik = Some (range ik) + let bot () = Some (Ints_t.zero, Ints_t.zero) + let bot_of ik = bot () (* TODO: improve *) + + let show = function None -> "bottom" | Some (x,y) -> Format.sprintf "z=%08x, o=%08x" (Ints_t.to_int x) (Ints_t.to_int y) + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) -> + if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> + if Ints_t.compare x y > 0 then + (None,{underflow=false; overflow=false}) + else ( + let (min_ik, max_ik) = range ik in + let underflow = Ints_t.compare min_ik x > 0 in + let overflow = Ints_t.compare max_ik y < 0 in + let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in + let v = + if underflow || overflow then + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in + let resdiff = Ints_t.abs (Ints_t.sub y x) in + if Ints_t.compare resdiff diff > 0 then + top_of ik + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if Ints_t.compare l u <= 0 then + Some (l, u) + else + (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) + top_of ik + else if not cast && should_ignore_overflow ik then + let tl, tu = BatOption.get @@ top_of ik in + Some (Ints_t.max tl x, Ints_t.min tu y) + else + top_of ik + else + Some (x,y) + in + (v, ov_info) + ) + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst + + let meet ik (x:t) y = + match x, y with + | None, z | z, None -> None + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst + + (* TODO: change to_int signature so it returns a big_int *) + let to_int x = Option.bind x (BArith.to_int) + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) + let of_int ik (x: int_t) = of_interval ik (x,x) + + + let of_bool _ik = function true -> top () | false -> bot () + let to_bool (a: t) = match a with + | None -> None + | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false + | x -> if leq( bot ()) x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) + + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) + + + let widen ik x y = + match x, y with + | None, z | z, None -> z + | Some (l0,u0), Some (l1,u1) -> + let nabla x y= (if x = Ints_t.logor x y then y else (Ints_t.of_int (-1) )) in + Some (nabla l0 l1, nabla u0 u1) + + + let narrow ik x y = None + + let log f ~annihilator ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) ~annihilator:true + let c_logand = log (&&) ~annihilator:false + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let bit f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + let bitcomp f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let logxor = bit (fun _ik -> Ints_t.logxor) + + let logand ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) + | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst + | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst + | _ -> top_of ik + + let logor = bit (fun _ik -> Ints_t.logor) + + let bit1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_int i1 with + | Some x -> of_int ik (f ik x) |> fst + | _ -> top_of ik + + let lognot = bit1 (fun _ik -> Ints_t.lognot) + let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) + + let neg ?no_ov ik v=(None,{underflow=false; overflow=false}) + + + + let add ?no_ov ik x y=(None,{underflow=false; overflow=false}) + let mul ?no_ov ik x y=(None,{underflow=false; overflow=false}) + let sub ?no_ov ik x y=(None,{underflow=false; overflow=false}) + + let shift_left ik a b =(None,{underflow=false; overflow=false}) + + let rem ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (xl, xu), Some (yl, yu) -> + if is_top_of ik x && is_top_of ik y then + (* This is needed to preserve soundness also on things bigger than int32 e.g. *) + (* x: 3803957176L -> T in Interval32 *) + (* y: 4209861404L -> T in Interval32 *) + (* x % y: 3803957176L -> T in Interval32 *) + (* T in Interval32 is [-2147483648,2147483647] *) + (* the code below computes [-2147483647,2147483647] for this though which is unsound *) + top_of ik + else + (* If we have definite values, Ints_t.rem will give a definite result. + * Otherwise we meet with a [range] the result can be in. + * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. + * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) + let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in + let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in + let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range + + let rec div ?no_ov ik x y =(None,{underflow=false; overflow=false}) + + let ne ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik true + else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then + of_bool ik false + else top () + + let eq ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then + of_bool ik true + else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik false + else top () + + let ge ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 then of_bool ik true + else if Ints_t.compare x2 y1 < 0 then of_bool ik false + else top () + + let le ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 <= 0 then of_bool ik true + else if Ints_t.compare y2 x1 < 0 then of_bool ik false + else top () + + let gt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 then of_bool ik true + else if Ints_t.compare x2 y1 <= 0 then of_bool ik false + else top () + + let lt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 < 0 then of_bool ik true + else if Ints_t.compare y2 x1 <= 0 then of_bool ik false + else top () + + let invariant_ikind e ik = function + | Some (x1, x2) -> + let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in + IntInvariant.of_interval e ik (x1', x2') + | None -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink = function + | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | None -> empty + in + QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) + + let modulo n k = + let result = Ints_t.rem n k in + if Ints_t.compare result Ints_t.zero >= 0 then result + else Ints_t.add result k + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None + else if Ints_t.equal m Ints_t.zero then + Some (c, c) + else + let (min_ik, max_ik) = range ik in + let rcx = + if Ints_t.equal x min_ik then x else + Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in + let lcy = + if Ints_t.equal y max_ik then y else + Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in + if Ints_t.compare rcx lcy > 0 then None + else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst + else norm ik @@ Some (rcx, lcy) |> fst + | _ -> None + + + + let refine_with_interval ik a b = meet ik a b + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + match intv, excl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls, (rl, rh)) -> + let rec shrink op b = + let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in + if not (Ints_t.equal b new_b) then shrink op new_b else new_b + in + let (min_ik, max_ik) = range ik in + let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in + let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in + let intv' = norm ik @@ Some (l', u') |> fst in + let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in + meet ik intv' range + + let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = + match intv, incl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls) -> + let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in + let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in + match min None ls, max None ls with + | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) + | _, _-> intv + + let project ik p t = t + end + + (** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = struct @@ -1612,6 +2128,7 @@ end module IntIkind = struct let ikind () = Cil.IInt end module Interval = IntervalFunctor (IntOps.BigIntOps) +module Bitfield = BitfieldFunctor (IntOps.BigIntOps) module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) @@ -3270,6 +3787,9 @@ end + + + (* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) (* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) module IntDomTupleImpl = struct @@ -3282,15 +3802,16 @@ module IntDomTupleImpl = struct module I3 = SOverflowLifter (Enums) module I4 = SOverflowLifter (Congruence) module I5 = IntervalSetFunctor (IntOps.BigIntOps) + module I6 = BitfieldFunctor (IntOps.BigIntOps) - type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option + type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option [@@deriving eq, ord, hash] let name () = "intdomtuple" (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) - let no_interval = Tuple5.map2 (const None) - let no_intervalSet = Tuple5.map5 (const None) + let no_interval = Tuple6.map2 (const None) + let no_intervalSet = Tuple6.map5 (const None) type 'a m = (module SOverflow with type t = 'a) type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) @@ -3308,14 +3829,14 @@ module IntDomTupleImpl = struct type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) - let create r x ((p1, p2, p3, p4, p5): int_precision) = + let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = let f b g = if b then Some (g x) else None in - f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5) + f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) let create r x = (* use where values are introduced *) create r x (int_precision_from_node_or_config ()) - let create2 r x ((p1, p2, p3, p4, p5): int_precision) = + let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = let f b g = if b then Some (g x) else None in - f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) + f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) let create2 r x = (* use where values are introduced *) create2 r x (int_precision_from_node_or_config ()) @@ -3334,13 +3855,13 @@ module IntDomTupleImpl = struct ); no_ov - let create2_ovc ik r x ((p1, p2, p3, p4, p5): int_precision) = + let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = let f b g = if b then Some (g x) else None in let map x = Option.map fst x in let intv = f p2 @@ r.fi2_ovc (module I2) in let intv_set = f p5 @@ r.fi2_ovc (module I5) in ignore (check_ov ~cast:false ik intv intv_set); - map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) + map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) let create2_ovc ik r x = (* use where values are introduced *) create2_ovc ik r x (int_precision_from_node_or_config ()) @@ -3349,25 +3870,28 @@ module IntDomTupleImpl = struct let opt_map2 f ?no_ov = curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None - let to_list x = Tuple5.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) + let to_list x = Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) let exists = function - | (Some true, _, _, _, _) - | (_, Some true, _, _, _) - | (_, _, Some true, _, _) - | (_, _, _, Some true, _) - | (_, _, _, _, Some true) -> - true + | (Some true, _, _, _, _,_) + | (_, Some true, _, _, _,_) + | (_, _, Some true, _, _,_) + | (_, _, _, Some true, _,_) + | (_, _, _, _, Some true,_) + | (_, _, _, _, _, Some true) + -> true | _ -> false let for_all = function - | (Some false, _, _, _, _) - | (_, Some false, _, _, _) - | (_, _, Some false, _, _) - | (_, _, _, Some false, _) - | (_, _, _, _, Some false) -> + | (Some false, _, _, _, _,_) + | (_, Some false, _, _, _,_) + | (_, _, Some false, _, _,_) + | (_, _, _, Some false, _,_) + | (_, _, _, _, Some false,_) + | (_, _, _, _, _, Some false) + -> false | _ -> true @@ -3385,7 +3909,7 @@ module IntDomTupleImpl = struct let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } - let refine_with_congruence ik ((a, b, c, d, e) : t) (cong : (int_t * int_t) option) : t= + let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= let opt f a = curry @@ function Some x, y -> Some (f a x y) | _ -> None in @@ -3393,9 +3917,11 @@ module IntDomTupleImpl = struct , opt I2.refine_with_congruence ik b cong , opt I3.refine_with_congruence ik c cong , opt I4.refine_with_congruence ik d cong - , opt I5.refine_with_congruence ik e cong) + , opt I5.refine_with_congruence ik e cong + , opt I6.refine_with_congruence ik f cong + ) - let refine_with_interval ik (a, b, c, d, e) intv = + let refine_with_interval ik (a, b, c, d, e,f) intv = let opt f a = curry @@ function Some x, y -> Some (f a x y) | _ -> None in @@ -3403,9 +3929,10 @@ module IntDomTupleImpl = struct , opt I2.refine_with_interval ik b intv , opt I3.refine_with_interval ik c intv , opt I4.refine_with_interval ik d intv - , opt I5.refine_with_interval ik e intv ) + , opt I5.refine_with_interval ik e intv + , opt I6.refine_with_interval ik f intv ) - let refine_with_excl_list ik (a, b, c, d, e) excl = + let refine_with_excl_list ik (a, b, c, d, e,f) excl = let opt f a = curry @@ function Some x, y -> Some (f a x y) | _ -> None in @@ -3413,9 +3940,10 @@ module IntDomTupleImpl = struct , opt I2.refine_with_excl_list ik b excl , opt I3.refine_with_excl_list ik c excl , opt I4.refine_with_excl_list ik d excl - , opt I5.refine_with_excl_list ik e excl ) + , opt I5.refine_with_excl_list ik e excl + , opt I6.refine_with_excl_list ik f excl ) - let refine_with_incl_list ik (a, b, c, d, e) incl = + let refine_with_incl_list ik (a, b, c, d, e,f) incl = let opt f a = curry @@ function Some x, y -> Some (f a x y) | _ -> None in @@ -3423,25 +3951,28 @@ module IntDomTupleImpl = struct , opt I2.refine_with_incl_list ik b incl , opt I3.refine_with_incl_list ik c incl , opt I4.refine_with_incl_list ik d incl - , opt I5.refine_with_incl_list ik e incl ) + , opt I5.refine_with_incl_list ik e incl + , opt I6.refine_with_incl_list ik f incl ) - let mapp r (a, b, c, d, e) = + let mapp r (a, b, c, d, e, f) = let map = BatOption.map in ( map (r.fp (module I1)) a , map (r.fp (module I2)) b , map (r.fp (module I3)) c , map (r.fp (module I4)) d - , map (r.fp (module I5)) e) + , map (r.fp (module I5)) e + , map (r.fp (module I6)) f) - let mapp2 r (a, b, c, d, e) = + let mapp2 r (a, b, c, d, e, f) = BatOption. ( map (r.fp2 (module I1)) a , map (r.fp2 (module I2)) b , map (r.fp2 (module I3)) c , map (r.fp2 (module I4)) d - , map (r.fp2 (module I5)) e) + , map (r.fp2 (module I5)) e + , map (r.fp2 (module I6)) f) (* exists/for_all *) @@ -3450,12 +3981,13 @@ module IntDomTupleImpl = struct let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } - let map2p r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = + let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = ( opt_map2 (r.f2p (module I1)) xa ya , opt_map2 (r.f2p (module I2)) xb yb , opt_map2 (r.f2p (module I3)) xc yc , opt_map2 (r.f2p (module I4)) xd yd - , opt_map2 (r.f2p (module I5)) xe ye) + , opt_map2 (r.f2p (module I5)) xe ye + , opt_map2 (r.f2p (module I6)) xf yf) (* f2p: binary projections *) let (%%) f g x = f % (g x) (* composition for binary function g *) @@ -3509,13 +4041,13 @@ module IntDomTupleImpl = struct let maybe reffun ik domtup dom = match dom with Some y -> reffun ik domtup y | _ -> domtup in - [(fun (a, b, c, d, e) -> refine_with_excl_list ik (a, b, c, d, e) (to_excl_list (a, b, c, d, e))); - (fun (a, b, c, d, e) -> refine_with_incl_list ik (a, b, c, d, e) (to_incl_list (a, b, c, d, e))); - (fun (a, b, c, d, e) -> maybe refine_with_interval ik (a, b, c, d, e) b); (* TODO: get interval across all domains with minimal and maximal *) - (fun (a, b, c, d, e) -> maybe refine_with_congruence ik (a, b, c, d, e) d)] + [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e,f) b); (* TODO: get interval across all domains with minimal and maximal *) + (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e,f) d)] - let refine ik ((a, b, c, d, e) : t ) : t = - let dt = ref (a, b, c, d, e) in + let refine ik ((a, b, c, d, e,f) : t ) : t = + let dt = ref (a, b, c, d, e,f) in (match get_refinement () with | "never" -> () | "once" -> @@ -3534,7 +4066,7 @@ module IntDomTupleImpl = struct (* map with overflow check *) - let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e) = + let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in let intv = map (r.f1_ovc (module I2)) b in let intv_set = map (r.f1_ovc (module I5)) e in @@ -3545,10 +4077,11 @@ module IntDomTupleImpl = struct , BatOption.map fst intv , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d - , BatOption.map fst intv_set ) + , BatOption.map fst intv_set + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) (* map2 with overflow check *) - let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = + let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in let no_ov = check_ov ~cast ik intv intv_set in @@ -3558,24 +4091,27 @@ module IntDomTupleImpl = struct , BatOption.map fst intv , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd - , BatOption.map fst intv_set ) + , BatOption.map fst intv_set + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) - let map ik r (a, b, c, d, e) = + let map ik r (a, b, c, d, e, f) = refine ik BatOption. ( map (r.f1 (module I1)) a , map (r.f1 (module I2)) b , map (r.f1 (module I3)) c , map (r.f1 (module I4)) d - , map (r.f1 (module I5)) e) + , map (r.f1 (module I5)) e + , map (r.f1 (module I6)) f) - let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = + let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = let r = ( opt_map2 (r.f2 (module I1)) xa ya , opt_map2 (r.f2 (module I2)) xb yb , opt_map2 (r.f2 (module I3)) xc yc , opt_map2 (r.f2 (module I4)) xd yd - , opt_map2 (r.f2 (module I5)) xe ye) + , opt_map2 (r.f2 (module I5)) xe ye + , opt_map2 (r.f2 (module I6)) xf yf) in if norefine then r else refine ik r @@ -3595,10 +4131,10 @@ module IntDomTupleImpl = struct (* fp: projections *) let equal_to i x = - let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple5.enum |> List.of_enum |> List.filter_map identity in + let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple6.enum |> List.of_enum |> List.filter_map identity in if List.mem `Eq xs then `Eq else if List.mem `Neq xs then `Neq else - `Top + `Top let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } @@ -3615,12 +4151,13 @@ module IntDomTupleImpl = struct (* `map/opt_map` are used by `project` *) let opt_map b f = curry @@ function None, true -> f | x, y when y || b -> x | _ -> None - let map ~keep r (i1, i2, i3, i4, i5) (b1, b2, b3, b4, b5) = + let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = ( opt_map keep (r.f3 (module I1)) i1 b1 , opt_map keep (r.f3 (module I2)) i2 b2 , opt_map keep (r.f3 (module I3)) i3 b3 , opt_map keep (r.f3 (module I4)) i4 b4 - , opt_map keep (r.f3 (module I5)) i5 b5 ) + , opt_map keep (r.f3 (module I5)) i5 b5 + , opt_map keep (r.f3 (module I6)) i6 b6) (** Project tuple t to precision p * We have to deactivate IntDomains after the refinement, since we might @@ -3723,7 +4260,7 @@ module IntDomTupleImpl = struct | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) - let invariant_ikind e ik ((_, _, _, x_cong, x_intset) as x) = + let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) let simplify_int fallback = match to_int x with @@ -3765,10 +4302,10 @@ module IntDomTupleImpl = struct | "all" -> simplify_int simplify_all | _ -> assert false - let arbitrary ik = QCheck.(set_print show @@ tup5 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik))) + let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) - let relift (a, b, c, d, e) = - (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e) + let relift (a, b, c, d, e, f) = + (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) end module IntDomTuple = diff --git a/src/cdomain/value/util/precisionUtil.ml b/src/cdomain/value/util/precisionUtil.ml index 047043b4aa..9f27f810c7 100644 --- a/src/cdomain/value/util/precisionUtil.ml +++ b/src/cdomain/value/util/precisionUtil.ml @@ -1,8 +1,8 @@ (** Integer and floating-point option and attribute handling. *) (* We define precision by the number of IntDomains activated. - * We currently have 5 types: DefExc, Interval, Enums, Congruence, IntervalSet *) -type int_precision = (bool * bool * bool * bool * bool) + * We currently have 5 types: DefExc, Interval, Enums, Congruence, IntervalSet, Bitfield*) +type int_precision = (bool * bool * bool * bool * bool * bool) (* Same applies for FloatDomain * We currently have only an interval type analysis *) type float_precision = (bool) @@ -12,6 +12,7 @@ let interval: bool option ref = ref None let enums: bool option ref = ref None let congruence: bool option ref = ref None let interval_set: bool option ref = ref None +let bitfield: bool option ref = ref None let get_def_exc () = if !def_exc = None then @@ -38,6 +39,11 @@ let get_interval_set () = interval_set := Some (GobConfig.get_bool "ana.int.interval_set"); Option.get !interval_set +let get_bitfield () = + if !bitfield = None then + bitfield := Some (GobConfig.get_bool "ana.int.bitfield"); + Option.get !bitfield + let annotation_int_enabled: bool option ref = ref None let get_annotation_int_enabled () = @@ -54,14 +60,15 @@ let reset_lazy () = annotation_int_enabled := None (* Thus for maximum precision we activate all Domains *) -let max_int_precision : int_precision = (true, true, true, true, true) +let max_int_precision : int_precision = (true, true, true, true, true, true) let max_float_precision : float_precision = (true) let int_precision_from_fundec (fd: GoblintCil.fundec): int_precision = ((ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_def_exc ()) ~removeAttr:"no-def_exc" ~keepAttr:"def_exc" fd), (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_interval ()) ~removeAttr:"no-interval" ~keepAttr:"interval" fd), (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_enums ()) ~removeAttr:"no-enums" ~keepAttr:"enums" fd), (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_congruence ()) ~removeAttr:"no-congruence" ~keepAttr:"congruence" fd), - (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_interval_set ()) ~removeAttr:"no-interval_set" ~keepAttr:"interval_set" fd)) + (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_interval_set ()) ~removeAttr:"no-interval_set" ~keepAttr:"interval_set" fd), + (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_bitfield ()) ~removeAttr:"no-bitfield" ~keepAttr:"bitfield" fd)) let float_precision_from_fundec (fd: GoblintCil.fundec): float_precision = ((ContextUtil.should_keep ~isAttr:GobPrecision ~keepOption:"ana.float.interval" ~removeAttr:"no-float-interval" ~keepAttr:"float-interval" fd)) @@ -70,7 +77,7 @@ let int_precision_from_node (): int_precision = | Some n -> int_precision_from_fundec (Node.find_fundec n) | _ -> max_int_precision (* In case a Node is None we have to handle Globals, i.e. we activate all IntDomains (TODO: verify this assumption) *) -let is_congruence_active (_, _, _, c,_: int_precision): bool = c +let is_congruence_active (_, _, _, c,_,_: int_precision): bool = c let float_precision_from_node (): float_precision = match !MyCFG.current_node with @@ -81,7 +88,7 @@ let int_precision_from_node_or_config (): int_precision = if get_annotation_int_enabled () then int_precision_from_node () else - (get_def_exc (), get_interval (), get_enums (), get_congruence (), get_interval_set ()) + (get_def_exc (), get_interval (), get_enums (), get_congruence (), get_interval_set (), get_bitfield ()) let float_precision_from_node_or_config (): float_precision = if GobConfig.get_bool "annotation.float.enabled" then diff --git a/src/config/options.schema.json b/src/config/options.schema.json index 447290b44d..f320b8301c 100644 --- a/src/config/options.schema.json +++ b/src/config/options.schema.json @@ -414,6 +414,13 @@ "type": "boolean", "default": false }, + "bitfield": { + "title": "ana.int.bitfield", + "description": + "Use IntDomain.Bitfield: Bitfield domain for integers.", + "type": "boolean", + "default": false + }, "congruence": { "title": "ana.int.congruence", "description": @@ -639,6 +646,12 @@ "Integer values of the IntervalSet domain in function contexts.", "type": "boolean", "default": true + }, + "bitfield": { + "title": "ana.base.context.bitfield", + "description": "Bitfield values in function contexts.", + "type": "boolean", + "default": true } }, "additionalProperties": false From a609f3da1f1d3e9806b643bff41df022cb5615e5 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 29 Oct 2024 13:52:50 +0100 Subject: [PATCH 004/111] fix bitfield domain --- src/cdomain/value/cdomains/intDomain.ml | 592 ++++++++++-------------- tests/regression/01-cpa/76-bitfield.c | 14 +- 2 files changed, 258 insertions(+), 348 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a67210adb7..45c718849f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1194,373 +1194,273 @@ end (* BitField arithmetic, without any overflow handling etc. *) module BitFieldArith (Ints_t : IntOps.IntOps) = struct - let of_int (z,o) = (Ints_t.lognot @@ Ints_t.of_int z, Ints_t.of_int o) + let zero_mask = Ints_t.zero + let one_mask = Ints_t.lognot zero_mask - let logneg (z,o) = (o,z) + let of_int v = (Ints_t.lognot v, v) - let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) + let lognot (z,o) = (o,z) - let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) + let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) - let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 (Ints_t.lognot o2)) (Ints_t.logand (Ints_t.lognot o1) o2), - Ints_t.logor (Ints_t.logand o1 (Ints_t.lognot o2)) (Ints_t.logand (Ints_t.lognot o1) o2)) - let shift_left (z,o) n = failwith "Not implemented" + let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) - let shift_right (z,o) n = failwith "Not implemented" + let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), + Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) - let to_int (x1, x2) = - if Ints_t.equal x1 x2 then Some x1 else None + let shift_left (z1,o1) (z2,o2) = failwith "Not implemented" -end + let shift_right (z1,o1) (z2,o2) = failwith "Not implemented" + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) -module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = - struct - let name () = "bitfield" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - module BArith = BitFieldArith (Ints_t) - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = Some (Ints_t.lognot (Ints_t.zero), Ints_t.zero) - let top_of ik = Some (range ik) - let bot () = Some (Ints_t.zero, Ints_t.zero) - let bot_of ik = bot () (* TODO: improve *) + let nabla x y= if x = Ints_t.logor x y then x else one_mask - let show = function None -> "bottom" | Some (x,y) -> Format.sprintf "z=%08x, o=%08x" (Ints_t.to_int x) (Ints_t.to_int y) - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) -> - if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> - if Ints_t.compare x y > 0 then - (None,{underflow=false; overflow=false}) - else ( - let (min_ik, max_ik) = range ik in - let underflow = Ints_t.compare min_ik x > 0 in - let overflow = Ints_t.compare max_ik y < 0 in - let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in - let v = - if underflow || overflow then - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in - let resdiff = Ints_t.abs (Ints_t.sub y x) in - if Ints_t.compare resdiff diff > 0 then - top_of ik - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if Ints_t.compare l u <= 0 then - Some (l, u) - else - (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) - top_of ik - else if not cast && should_ignore_overflow ik then - let tl, tu = BatOption.get @@ top_of ik in - Some (Ints_t.max tl x, Ints_t.min tu y) - else - top_of ik - else - Some (x,y) - in - (v, ov_info) - ) - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst - - let meet ik (x:t) y = - match x, y with - | None, z | z, None -> None - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst - - (* TODO: change to_int signature so it returns a big_int *) - let to_int x = Option.bind x (BArith.to_int) - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) - let of_int ik (x: int_t) = of_interval ik (x,x) + let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) + let zero = of_int (Ints_t.of_int 0) + let one = of_int (Ints_t.of_int 1) - let of_bool _ik = function true -> top () | false -> bot () - let to_bool (a: t) = match a with - | None -> None - | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false - | x -> if leq( bot ()) x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) - - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) - + let topbool = join zero one - let widen ik x y = - match x, y with - | None, z | z, None -> z - | Some (l0,u0), Some (l1,u1) -> - let nabla x y= (if x = Ints_t.logor x y then y else (Ints_t.of_int (-1) )) in - Some (nabla l0 l1, nabla u0 u1) + let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2 && Ints_t.equal o1 o2) + let includes (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.lognot z1 ) z2 = one_mask) && + (Ints_t.logor (Ints_t.lognot o1 ) o2 = one_mask) + + let is_constant (z,o) = (Ints_t.logxor z o) = one_mask + +end + +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct + let name () = "bitfield" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] + module BArith = BitFieldArith (Ints_t) + + + let top () = (Ints_t.lognot (Ints_t.zero), Ints_t.lognot (Ints_t.zero)) + let top_of ik = top () + let bot () = (Ints_t.zero, Ints_t.zero) + let bot_of ik = bot () + + let show t = + if t = bot () then "bot" else + if t = top () then "top" else + let (z,o) = t in + if BArith.is_constant t then + Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) + else + Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let join ik x y = BArith.join x y + + let meet ik x y = BArith.meet x y + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik (z,o) = + M.trace "bitfield" "norm"; + ((z,o), {underflow=false; overflow=false}) + + let to_int (z,o) = if is_bot (z,o) then None else + if BArith.is_constant (z,o) then Some o + else None + + let equal_to i (u,l) = + M.trace "bitfield" "equal_to"; + if BArith.of_int i = (u,l) then `Eq + else if BArith.includes (u,l) (BArith.of_int i) then `Top + else `Neq + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + M.trace "bitfield" "of_interval"; + failwith "Not implemented" + + let of_int ik (x: int_t) = (BArith.of_int x, {underflow=false; overflow=false}) + + let of_bool _ik = function true -> BArith.one | false -> BArith.zero - let narrow ik x y = None - - let log f ~annihilator ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, _ when x = annihilator -> of_bool ik annihilator - | _, Some y when y = annihilator -> of_bool ik annihilator - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) ~annihilator:true - let c_logand = log (&&) ~annihilator:false - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let bit f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - let bitcomp f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let logxor = bit (fun _ik -> Ints_t.logxor) - - let logand ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) - | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst - | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst - | _ -> top_of ik - - let logor = bit (fun _ik -> Ints_t.logor) - - let bit1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_int i1 with - | Some x -> of_int ik (f ik x) |> fst - | _ -> top_of ik - - let lognot = bit1 (fun _ik -> Ints_t.lognot) - let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) - - let neg ?no_ov ik v=(None,{underflow=false; overflow=false}) - - - - let add ?no_ov ik x y=(None,{underflow=false; overflow=false}) - let mul ?no_ov ik x y=(None,{underflow=false; overflow=false}) - let sub ?no_ov ik x y=(None,{underflow=false; overflow=false}) - - let shift_left ik a b =(None,{underflow=false; overflow=false}) - - let rem ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (xl, xu), Some (yl, yu) -> - if is_top_of ik x && is_top_of ik y then - (* This is needed to preserve soundness also on things bigger than int32 e.g. *) - (* x: 3803957176L -> T in Interval32 *) - (* y: 4209861404L -> T in Interval32 *) - (* x % y: 3803957176L -> T in Interval32 *) - (* T in Interval32 is [-2147483648,2147483647] *) - (* the code below computes [-2147483647,2147483647] for this though which is unsound *) - top_of ik - else - (* If we have definite values, Ints_t.rem will give a definite result. - * Otherwise we meet with a [range] the result can be in. - * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. - * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) - let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in - let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in - let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range + let to_bool d= + M.trace "bitfield" "to_bool"; + if not (BArith.includes BArith.zero d ) then Some true + else if BArith.eq d BArith.zero then Some false + else None + + let starting ?(suppress_ovwarn=false) ik n = + M.trace "bitfield" "starting"; + (top(), {underflow=false; overflow=false}) - let rec div ?no_ov ik x y =(None,{underflow=false; overflow=false}) + let ending ?(suppress_ovwarn=false) ik n = + M.trace "bitfield" "ending"; + (top(), {underflow=false; overflow=false}) + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = + M.trace "bitfield" "cast_to"; + norm ~cast:true t (* norm does all overflow handling *) + + let widen ik x y = BArith.widen x y + + let narrow ik x y = meet ik x y + + let log1 f ik i1 = match to_bool i1 with + | None -> top_of ik + | Some x -> of_bool ik (f x) + + let log2 f ik i1 i2 = match (to_bool i1, to_bool i2) with + | None, None -> top_of ik + | None, Some x | Some x, None -> of_bool ik x + | Some x, Some y -> of_bool ik (f x y) + + let c_logor ik i1 i2 = log2 (||) ik i1 i2 + + let c_logand ik i1 i2 = log2 (&&) ik i1 i2 + + let c_lognot ik i1 = log1 not ik i1 + + let xor a b = (a && not b) || (not a && b) + + let logxor ik i1 i2 = BArith.logxor i1 i2 + + let logand ik i1 i2 = BArith.logand i1 i2 + + let logor ik i1 i2 = BArith.logor i1 i2 + + let lognot ik i1 = BArith.lognot i1 + + let neg ?no_ov ik v = + M.trace "bitfield" "neg"; + failwith "Not implemented" + + let shift_right ik a b = + M.trace "bitfield" "shift_right"; + failwith "Not implemented" + + let shift_left ik a b = + M.trace "bitfield" "shift_left"; + failwith "Not implemented" + + let add ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) + let mul ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) + let sub ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) + + let shift_left ik a b =(top_of ik,{underflow=false; overflow=false}) + + let rem ik x y = + M.trace "bitfield" "rem"; + top_of ik + + let rec div ?no_ov ik x y =(top_of ik,{underflow=false; overflow=false}) + + + let eq ik x y = + M.trace "bitfield" "eq"; + if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) + else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik false + else BArith.topbool + let ne ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik true - else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then - of_bool ik false - else top () - - let eq ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then - of_bool ik true - else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik false - else top () - - let ge ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 then of_bool ik true - else if Ints_t.compare x2 y1 < 0 then of_bool ik false - else top () - - let le ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 <= 0 then of_bool ik true - else if Ints_t.compare y2 x1 < 0 then of_bool ik false - else top () - - let gt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 then of_bool ik true - else if Ints_t.compare x2 y1 <= 0 then of_bool ik false - else top () - - let lt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 < 0 then of_bool ik true - else if Ints_t.compare y2 x1 <= 0 then of_bool ik false - else top () - - let invariant_ikind e ik = function - | Some (x1, x2) -> - let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in - IntInvariant.of_interval e ik (x1', x2') - | None -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink = function - | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) - | None -> empty - in - QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) - - let modulo n k = - let result = Ints_t.rem n k in - if Ints_t.compare result Ints_t.zero >= 0 then result - else Ints_t.add result k - - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None - else if Ints_t.equal m Ints_t.zero then - Some (c, c) - else - let (min_ik, max_ik) = range ik in - let rcx = - if Ints_t.equal x min_ik then x else - Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in - let lcy = - if Ints_t.equal y max_ik then y else - Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in - if Ints_t.compare rcx lcy > 0 then None - else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst - else norm ik @@ Some (rcx, lcy) |> fst - | _ -> None - + if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) + else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik true + else BArith.topbool + + + let leq (x:t) (y:t) = BArith.includes x y + + type comparison_result = + | Less + | LessOrEqual + | Greater + | GreaterOrEqual + | Unknown + +let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = + M.trace "bitfield" "compare_bitfields"; + let bit_length = Sys.word_size - 2 in (* Set bit length based on system word size *) + let sign_bit_position = if signed then bit_length - 1 else -1 in + let result = ref Unknown in + + (* Helper function to check bits at each position *) + let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 in + + (* Iterate from Most Significant Bit (MSB) to Least Significant Bit (LSB) *) + for i = bit_length - 1 downto 0 do + let bit1_zero = get_bit z1 i in + let bit1_one = get_bit o1 i in + let bit2_zero = get_bit z2 i in + let bit2_one = get_bit o2 i in + + (* Check if bits at position i are both known *) + if (bit1_zero || bit1_one) && (bit2_zero || bit2_one) then + if bit1_zero && bit2_one then begin + result := if strict then Less else LessOrEqual; + raise Exit + end else if bit1_one && bit2_zero then begin + result := if strict then Greater else GreaterOrEqual; + raise Exit + end else if (bit1_one = bit2_one) && (bit1_zero = bit2_zero) then + () (* Equal bits, continue checking lower bits *) + else + result := Unknown (* Unknown bit situation, stop *) + else + result := Unknown; + raise Exit + done; + (* Handle sign bit adjustment if signed *) + if signed && !result <> Unknown then + match !result with + | Less when get_bit o1 sign_bit_position <> get_bit o2 sign_bit_position -> result := Greater + | Greater when get_bit o1 sign_bit_position <> get_bit o2 sign_bit_position -> result := Less + | _ -> (); + else (); + + (* Handle non-strict inequalities for unknowns *) + if not strict && !result = Unknown then begin + if (Ints_t.logand z1 o2) = Ints_t.zero then result := LessOrEqual + else if (Ints_t.logand o1 z2) = Ints_t.zero then result := GreaterOrEqual + end; + !result + + let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.topbool + + let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.topbool + + let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.topbool + + let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.topbool + + let invariant_ikind e ik = + M.trace "bitfield" "invariant_ikind"; + failwith "Not implemented" + + let arbitrary ik = + M.trace "bitfield" "arbitrary"; + failwith "Not implemented" + + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + M.trace "bitfield" "refine_with_congruence"; + top_of ik - let refine_with_interval ik a b = meet ik a b - - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - match intv, excl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls, (rl, rh)) -> - let rec shrink op b = - let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in - if not (Ints_t.equal b new_b) then shrink op new_b else new_b - in - let (min_ik, max_ik) = range ik in - let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in - let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in - let intv' = norm ik @@ Some (l', u') |> fst in - let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in - meet ik intv' range - - let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = - match intv, incl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls) -> - let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in - let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in - match min None ls, max None ls with - | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) - | _, _-> intv - - let project ik p t = t - end + let refine_with_interval ik a b = + M.trace "bitfield" "refine_with_interval"; + top_of ik + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + M.trace "bitfield" "refine_with_excl_list"; + top_of ik + + let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = + M.trace "bitfield" "refine_with_incl_list"; + top_of ik + + let project ik p t = t +end (** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) diff --git a/tests/regression/01-cpa/76-bitfield.c b/tests/regression/01-cpa/76-bitfield.c index aca9ab28dc..0054f00ee4 100644 --- a/tests/regression/01-cpa/76-bitfield.c +++ b/tests/regression/01-cpa/76-bitfield.c @@ -4,22 +4,32 @@ #define ANY_ERROR 5 // 5 int main() { - - int testvar=11; + int testvar = 235; int state; int r = rand() % 3; // {r 7→ [0; 2],state 7→ [MIN INT; MAX INT]} switch (r) { case 0: state = 0; /* 0 */ + testvar = 1; break; case 1: state = 8; /* 8 */ + testvar = 1; break; default: state = 10; /* 10 */ + testvar = 1; break; } + + if(state & ANY_ERROR == 0) { + printf("Error\n"); + } else { + printf("No error\n"); + } + // {r 7→ [0; 2],state 7→ [0; 10]} assert((state & ANY_ERROR) == 0); + __goblint_check((state & ANY_ERROR) == 0); } From 696c1103a27fb24e8516488467b6d080a73134af Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Mon, 4 Nov 2024 15:37:50 +0100 Subject: [PATCH 005/111] Draft of incredibly messy impls of bitfield shift operations that need some revision. Possible side-effects and runtime in O(n^2) while O(n) should be possible. --- src/cdomain/value/cdomains/intDomain.ml | 112 ++++++++++++++++++------ 1 file changed, 84 insertions(+), 28 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 45c718849f..2debf55b8f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1197,7 +1197,13 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask + let is_const (z,o) = (Ints_t.logxor z o) = one_mask + let of_int v = (Ints_t.lognot v, v) + let to_int (z, o) = if is_const (z,o) then Some o else None + + let zero = of_int (Ints_t.of_int 0) + let one = of_int (Ints_t.of_int 1) let lognot (z,o) = (o,z) @@ -1208,11 +1214,56 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) - let shift_left (z1,o1) (z2,o2) = failwith "Not implemented" + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - let shift_right (z1,o1) (z2,o2) = failwith "Not implemented" + let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 + let set_bit ?(zero=true) mask pos = + let one_mask = Ints_t.shift_left Ints_t.one pos in + if zero then + let zero_mask = Ints_t.lognot one_mask in + Ints_t.logand mask zero_mask + else + Ints_t.logor mask one_mask - let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + let break_down ikind_size (z, o) : Ints_t.t list option = + (* check if the abstract bitfield has undefined bits i.e. at some pos i the bit is neither 1 or 0 *) + if Ints_t.compare (Ints_t.lognot @@ Ints_t.logor (Ints_t.lognot z) o) Ints_t.zero = 0 + then None + else + let result = ref [o] in + for i = ikind_size - 1 downto 0 do + if get_bit z i = get_bit o i then + let with_one = !result in + let with_zero = List.map (fun elm -> set_bit elm i) with_one in + result := with_one @ with_zero + done; + Some (!result) + + let shift_left ikind_size (z1,o1) (z2,o2) = + let shift_by n (z, o) = + let z_or_mask = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in + (Ints_t.logor (Ints_t.shift_left z n) z_or_mask, Ints_t.shift_left o n) + in + if is_const (z2, o2) then shift_by (Ints_t.to_int o2) (z1, o1) |> Option.some + else + (* naive impl in O(n^2) *) + match break_down ikind_size (z2, o2) with None -> None + | Some c_lst -> + List.map (fun c -> shift_by (Ints_t.to_int c) (z1, o1)) c_lst + |> List.fold_left join zero + |> Option.some + + let shift_right ikind_size (z1,o1) (z2,o2) = + let shift_by n (z, o) = (Ints_t.shift_right z n, Ints_t.shift_right o n) + in + if is_const (z2, o2) then shift_by (Ints_t.to_int o2) (z1, o1) |> Option.some + else + (* naive impl in O(n^2) *) + match break_down ikind_size (z2, o2) with None -> None + | Some c_lst -> + List.map (fun c -> shift_by (Ints_t.to_int c) (z1, o1)) c_lst + |> List.fold_left join zero + |> Option.some let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) @@ -1220,18 +1271,13 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) - let zero = of_int (Ints_t.of_int 0) - let one = of_int (Ints_t.of_int 1) - - let topbool = join zero one + let top_bool = join zero one let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2 && Ints_t.equal o1 o2) let includes (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.lognot z1 ) z2 = one_mask) && (Ints_t.logor (Ints_t.lognot o1 ) o2 = one_mask) - let is_constant (z,o) = (Ints_t.logxor z o) = one_mask - end module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct @@ -1250,7 +1296,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in - if BArith.is_constant t then + if BArith.is_const t then Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) else Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) @@ -1268,7 +1314,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int ((z,o), {underflow=false; overflow=false}) let to_int (z,o) = if is_bot (z,o) then None else - if BArith.is_constant (z,o) then Some o + if BArith.is_const (z,o) then Some o else None let equal_to i (u,l) = @@ -1338,11 +1384,21 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - failwith "Not implemented" + failwith "TODO" + (* + match BArith.shift_right ik a b with + | None -> (bot (), {underflow=false; overflow=false}) (*TODO*) + | Some x -> (x, {underflow=false; overflow=false}) (*TODO*) + *) let shift_left ik a b = M.trace "bitfield" "shift_left"; - failwith "Not implemented" + failwith "TODO" + (* + match BArith.shift_left ik a b with + | None -> (bot (), {underflow=false; overflow=false}) (*TODO*) + | Some x -> (x, {underflow=false; overflow=false}) (*TODO*) + *) let add ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) let mul ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) @@ -1359,14 +1415,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let eq ik x y = M.trace "bitfield" "eq"; - if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) + if BArith.is_const x && BArith.is_const y then of_bool ik (BArith.eq x y) else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik false - else BArith.topbool + else BArith.top_bool let ne ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) + if BArith.is_const x && BArith.is_const y then of_bool ik (not (BArith.eq x y)) else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik true - else BArith.topbool + else BArith.top_bool let leq (x:t) (y:t) = BArith.includes x y @@ -1385,14 +1441,14 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = let result = ref Unknown in (* Helper function to check bits at each position *) - let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 in + (* let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 in *) (* Iterate from Most Significant Bit (MSB) to Least Significant Bit (LSB) *) for i = bit_length - 1 downto 0 do - let bit1_zero = get_bit z1 i in - let bit1_one = get_bit o1 i in - let bit2_zero = get_bit z2 i in - let bit2_one = get_bit o2 i in + let bit1_zero = BArith.get_bit z1 i in + let bit1_one = BArith.get_bit o1 i in + let bit2_zero = BArith.get_bit z2 i in + let bit2_one = BArith.get_bit o2 i in (* Check if bits at position i are both known *) if (bit1_zero || bit1_one) && (bit2_zero || bit2_one) then @@ -1414,8 +1470,8 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = (* Handle sign bit adjustment if signed *) if signed && !result <> Unknown then match !result with - | Less when get_bit o1 sign_bit_position <> get_bit o2 sign_bit_position -> result := Greater - | Greater when get_bit o1 sign_bit_position <> get_bit o2 sign_bit_position -> result := Less + | Less when BArith.get_bit o1 sign_bit_position <> BArith.get_bit o2 sign_bit_position -> result := Greater + | Greater when BArith.get_bit o1 sign_bit_position <> BArith.get_bit o2 sign_bit_position -> result := Less | _ -> (); else (); @@ -1426,13 +1482,13 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = end; !result - let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.topbool + let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.top_bool - let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.topbool + let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.top_bool - let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.topbool + let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.top_bool - let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.topbool + let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.top_bool let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; From 0630662abcda18fd302908410222cd0c49ba1dda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Mon, 4 Nov 2024 17:23:51 +0100 Subject: [PATCH 006/111] some bug fixes --- src/cdomain/value/cdomains/intDomain.ml | 39 ++++++++++++++++--------- 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 45c718849f..9a71f61d1c 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1220,8 +1220,8 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) - let zero = of_int (Ints_t.of_int 0) - let one = of_int (Ints_t.of_int 1) + let zero = of_int Ints_t.zero + let one = of_int Ints_t.one let topbool = join zero one @@ -1232,6 +1232,11 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let is_constant (z,o) = (Ints_t.logxor z o) = one_mask + (* assumes that no invalid state can be reached*) + let max (z,o) = (if o < Ints_t.zero then Ints_t.neg z else o) + + let min (z,o) = (if o < Ints_t.zero then o else Ints_t.neg z) + end module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct @@ -1285,9 +1290,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_bool _ik = function true -> BArith.one | false -> BArith.zero - let to_bool d= + let to_bool d = M.trace "bitfield" "to_bool"; - if not (BArith.includes BArith.zero d ) then Some true + if not (BArith.includes d BArith.zero ) then Some true else if BArith.eq d BArith.zero then Some false else None @@ -1363,13 +1368,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik false else BArith.topbool - let ne ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) - else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik true - else BArith.topbool + let ne ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) + else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik true + else BArith.topbool - let leq (x:t) (y:t) = BArith.includes x y + let leq (x:t) (y:t) = (BArith.max x) <= (BArith.min y) type comparison_result = | Less @@ -1426,13 +1431,21 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = end; !result - let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.topbool + let ge ik x y = if (BArith.min x) >= (BArith.max y) then of_bool ik true + else if (BArith.max x) < (BArith.min y) then of_bool ik false + else BArith.topbool - let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.topbool + let le ik x y = if (BArith.max x) <= (BArith.min y) then of_bool ik true + else if (BArith.min x) > (BArith.max y) then of_bool ik false + else BArith.topbool - let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.topbool + let gt ik x y = if (BArith.min x) > (BArith.max y) then of_bool ik true + else if (BArith.max x) <= (BArith.min y) then of_bool ik false + else BArith.topbool - let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.topbool + let lt ik x y = if (BArith.max x) < (BArith.min y) then of_bool ik true + else if (BArith.min x) >= (BArith.max y) then of_bool ik false + else BArith.topbool let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; From fd899077b10a375f390efb18d12dcd07030ea86e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Mon, 4 Nov 2024 22:34:04 +0100 Subject: [PATCH 007/111] implemented add, sub and mul --- src/cdomain/value/cdomains/intDomain.ml | 35 ++++++++++++++++++++----- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 9a71f61d1c..acab64b3ba 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1349,18 +1349,39 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int M.trace "bitfield" "shift_left"; failwith "Not implemented" - let add ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) - let mul ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) - let sub ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) - let shift_left ik a b =(top_of ik,{underflow=false; overflow=false}) - let rem ik x y = - M.trace "bitfield" "rem"; - top_of ik + let add ?no_ov ik (z1, o1) (z2, o2) = + let undef = Ints_t.logor (Ints_t.logand o1 z1) (Ints_t.logand o2 z2) in + let z3 = Ints_t.logor (Ints_t.neg (Ints_t.sub (Ints_t.neg z1) (Ints_t.neg z2))) undef in + let o3 = Ints_t.logor (Ints_t.sub o1 o2) undef in + ((z3, o3),{underflow=false; overflow=false}) + + let sub ?no_ov ik (z1, o1) (z2, o2) = + let undef = Ints_t.logor (Ints_t.logand o1 z1) (Ints_t.logand o2 z2) in + let z3 = Ints_t.logor (Ints_t.neg (Ints_t.sub (Ints_t.neg z1) (Ints_t.neg z2))) undef in + let o3 = Ints_t.logor (Ints_t.sub o1 o2) undef in + ((z3, o3),{underflow=false; overflow=false}) + + let mul ?no_ov ik (z1, o1) (z2, o2) = + let u1 = Ints_t.logand o1 z1 in + let u2 = Ints_t.logand o2 z2 in + let c1 = Ints_t.logand o1 (Ints_t.neg z1) in + let c2 = Ints_t.logand o2 (Ints_t.neg z2) in + let o3 = Ints_t.mul c1 c2 in + let z3 = Ints_t.neg o3 in + let t1 = Ints_t.mul c1 u2 in + let t2 = Ints_t.mul u1 c2 in + let t3 = Ints_t.mul u1 u2 in + let o3 = Ints_t.logor (Ints_t.logor (Ints_t.logor o3 t1) t2) t3 in + let z3 = Ints_t.logor (Ints_t.logor (Ints_t.logor z3 t1) t2) t3 in + ((z3, o3),{underflow=false; overflow=false}) let rec div ?no_ov ik x y =(top_of ik,{underflow=false; overflow=false}) + let rem ik x y = + M.trace "bitfield" "rem"; + top_of ik let eq ik x y = M.trace "bitfield" "eq"; From 8a918298fe76d2715ef21203cf3047f084a146bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 5 Nov 2024 12:45:38 +0100 Subject: [PATCH 008/111] reverted some changes due to incorrect implementations --- src/cdomain/value/cdomains/intDomain.ml | 52 ++++++------------------- 1 file changed, 12 insertions(+), 40 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index acab64b3ba..5cac3d727b 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1351,33 +1351,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_left ik a b =(top_of ik,{underflow=false; overflow=false}) - let add ?no_ov ik (z1, o1) (z2, o2) = - let undef = Ints_t.logor (Ints_t.logand o1 z1) (Ints_t.logand o2 z2) in - let z3 = Ints_t.logor (Ints_t.neg (Ints_t.sub (Ints_t.neg z1) (Ints_t.neg z2))) undef in - let o3 = Ints_t.logor (Ints_t.sub o1 o2) undef in - ((z3, o3),{underflow=false; overflow=false}) - - let sub ?no_ov ik (z1, o1) (z2, o2) = - let undef = Ints_t.logor (Ints_t.logand o1 z1) (Ints_t.logand o2 z2) in - let z3 = Ints_t.logor (Ints_t.neg (Ints_t.sub (Ints_t.neg z1) (Ints_t.neg z2))) undef in - let o3 = Ints_t.logor (Ints_t.sub o1 o2) undef in - ((z3, o3),{underflow=false; overflow=false}) - - let mul ?no_ov ik (z1, o1) (z2, o2) = - let u1 = Ints_t.logand o1 z1 in - let u2 = Ints_t.logand o2 z2 in - let c1 = Ints_t.logand o1 (Ints_t.neg z1) in - let c2 = Ints_t.logand o2 (Ints_t.neg z2) in - let o3 = Ints_t.mul c1 c2 in - let z3 = Ints_t.neg o3 in - let t1 = Ints_t.mul c1 u2 in - let t2 = Ints_t.mul u1 c2 in - let t3 = Ints_t.mul u1 u2 in - let o3 = Ints_t.logor (Ints_t.logor (Ints_t.logor o3 t1) t2) t3 in - let z3 = Ints_t.logor (Ints_t.logor (Ints_t.logor z3 t1) t2) t3 in - ((z3, o3),{underflow=false; overflow=false}) - - let rec div ?no_ov ik x y =(top_of ik,{underflow=false; overflow=false}) + let add ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) + + let sub ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) + + let mul ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) + + let rec div ?no_ov ik x y = (top_of ik,{underflow=false; overflow=false}) let rem ik x y = M.trace "bitfield" "rem"; @@ -1395,7 +1375,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else BArith.topbool - let leq (x:t) (y:t) = (BArith.max x) <= (BArith.min y) + let leq (x:t) (y:t) = BArith.includes x y type comparison_result = | Less @@ -1452,21 +1432,13 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = end; !result - let ge ik x y = if (BArith.min x) >= (BArith.max y) then of_bool ik true - else if (BArith.max x) < (BArith.min y) then of_bool ik false - else BArith.topbool + let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.topbool - let le ik x y = if (BArith.max x) <= (BArith.min y) then of_bool ik true - else if (BArith.min x) > (BArith.max y) then of_bool ik false - else BArith.topbool + let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.topbool - let gt ik x y = if (BArith.min x) > (BArith.max y) then of_bool ik true - else if (BArith.max x) <= (BArith.min y) then of_bool ik false - else BArith.topbool + let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.topbool - let lt ik x y = if (BArith.max x) < (BArith.min y) then of_bool ik true - else if (BArith.min x) >= (BArith.max y) then of_bool ik false - else BArith.topbool + let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.topbool let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; From 5c0fdbbbfeed0e4c4d3cf0f76900eb41dc169279 Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Tue, 5 Nov 2024 22:17:08 +0100 Subject: [PATCH 009/111] optimized shifts that concretize the shifting constants from an abstract bitfield by eliminating constants that would result in a shift to zero beforehand --- src/cdomain/value/cdomains/intDomain.ml | 77 +++++++++++++------------ 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 2debf55b8f..7347156dbd 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1217,7 +1217,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 - let set_bit ?(zero=true) mask pos = + let set_bit ?(zero=false) mask pos = let one_mask = Ints_t.shift_left Ints_t.one pos in if zero then let zero_mask = Ints_t.lognot one_mask in @@ -1225,43 +1225,50 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct else Ints_t.logor mask one_mask - let break_down ikind_size (z, o) : Ints_t.t list option = + (* max number of (left or right) shifts on an ikind s.t. 0 results from it *) + (* TODO hard coded. Other impl? *) + let max_shift (ik: Cil.ikind) = + let ilog2 n = + let rec aux n acc = + if n = 1 then acc + else aux (n lsr 1) (acc + 1) + in + Cil.bytesSizeOfInt ik * 8 |> ilog2 + + (* concretizes an abstract bitfield into a set of minimal bitfields that represent concrete numbers + used for shifting bitfields for an ikind in WC O( 2^(log(n)) ) with n = ikind size *) + let break_down ik (z, o) : Ints_t.t list option = (* check if the abstract bitfield has undefined bits i.e. at some pos i the bit is neither 1 or 0 *) - if Ints_t.compare (Ints_t.lognot @@ Ints_t.logor (Ints_t.lognot z) o) Ints_t.zero = 0 + if Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 then None else - let result = ref [o] in - for i = ikind_size - 1 downto 0 do + let n = max_shift ik in + let zero_extend_mask = Ints_t.shift_left Ints_t.one n + |> fun x -> Ints_t.sub x Ints_t.one + |> Ints_t.lognot in + let result = ref [Ints_t.logand o zero_extend_mask] in + for i = 0 to n - 1 do if get_bit z i = get_bit o i then let with_one = !result in - let with_zero = List.map (fun elm -> set_bit elm i) with_one in + let with_zero = List.map (fun elm -> set_bit ~zero:true elm i) with_one in result := with_one @ with_zero done; Some (!result) - let shift_left ikind_size (z1,o1) (z2,o2) = + let shift ?left ik a n = let shift_by n (z, o) = - let z_or_mask = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in - (Ints_t.logor (Ints_t.shift_left z n) z_or_mask, Ints_t.shift_left o n) - in - if is_const (z2, o2) then shift_by (Ints_t.to_int o2) (z1, o1) |> Option.some - else - (* naive impl in O(n^2) *) - match break_down ikind_size (z2, o2) with None -> None - | Some c_lst -> - List.map (fun c -> shift_by (Ints_t.to_int c) (z1, o1)) c_lst - |> List.fold_left join zero - |> Option.some - - let shift_right ikind_size (z1,o1) (z2,o2) = - let shift_by n (z, o) = (Ints_t.shift_right z n, Ints_t.shift_right o n) + if left then + let z_or_mask = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one + in (Ints_t.logor (Ints_t.shift_left z n) z_or_mask, Ints_t.shift_left o n) + else + (Ints_t.shift_right z n, Ints_t.shift_right o n) in + if is_const (z2, o2) then shift_by (Ints_t.to_int o2) (z1, o1) |> Option.some in - if is_const (z2, o2) then shift_by (Ints_t.to_int o2) (z1, o1) |> Option.some + if is_const n then shift_by (Ints_t.to_int @@ snd n) a |> Option.some else - (* naive impl in O(n^2) *) - match break_down ikind_size (z2, o2) with None -> None + match break_down ik n with None -> None | Some c_lst -> - List.map (fun c -> shift_by (Ints_t.to_int c) (z1, o1)) c_lst + List.map (fun c -> shift_by (Ints_t.to_int @@ snd n) a) c_lst |> List.fold_left join zero |> Option.some @@ -1382,23 +1389,19 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int M.trace "bitfield" "neg"; failwith "Not implemented" + (*TODO no overflow handling for shifts?*) + (*TODO move shift impl here due to dependancy to ikind?*) let shift_right ik a b = M.trace "bitfield" "shift_right"; - failwith "TODO" - (* - match BArith.shift_right ik a b with - | None -> (bot (), {underflow=false; overflow=false}) (*TODO*) - | Some x -> (x, {underflow=false; overflow=false}) (*TODO*) - *) + match BArith.shift ~left:false ik a b with + | None -> (bot (), {underflow=false; overflow=false}) + | Some x -> (x, {underflow=false; overflow=false}) let shift_left ik a b = M.trace "bitfield" "shift_left"; - failwith "TODO" - (* - match BArith.shift_left ik a b with - | None -> (bot (), {underflow=false; overflow=false}) (*TODO*) - | Some x -> (x, {underflow=false; overflow=false}) (*TODO*) - *) + match BArith.shift ~left:true ik a b with + | None -> (bot (), {underflow=false; overflow=false}) + | Some x -> (x, {underflow=false; overflow=false}) let add ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) let mul ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) From 087d4a925213b3b0cec940be125aeeebfe976884 Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Tue, 5 Nov 2024 22:28:36 +0100 Subject: [PATCH 010/111] minor bug in max_shift --- src/cdomain/value/cdomains/intDomain.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 7347156dbd..b9981c461d 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1232,6 +1232,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let rec aux n acc = if n = 1 then acc else aux (n lsr 1) (acc + 1) + in aux n 0 in Cil.bytesSizeOfInt ik * 8 |> ilog2 From 0116023ec192d55efff67402e9a1233e0d5391a3 Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Tue, 5 Nov 2024 22:32:03 +0100 Subject: [PATCH 011/111] comparison bug in max_shift --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index b9981c461d..f0711dda83 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1230,7 +1230,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let max_shift (ik: Cil.ikind) = let ilog2 n = let rec aux n acc = - if n = 1 then acc + if n <= 1 then acc else aux (n lsr 1) (acc + 1) in aux n 0 in From 03961c0e328e24af533e1dd92c220d8c6d416824 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Thu, 7 Nov 2024 04:43:24 +0100 Subject: [PATCH 012/111] begin overflow handling --- src/cdomain/value/cdomains/intDomain.ml | 233 +++++++++++------------- 1 file changed, 104 insertions(+), 129 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5cac3d727b..4581a1a857 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1189,67 +1189,105 @@ struct let project ik p t = t end - - -(* BitField arithmetic, without any overflow handling etc. *) module BitFieldArith (Ints_t : IntOps.IntOps) = struct - let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask - let of_int v = (Ints_t.lognot v, v) + let of_int x = (Ints_t.lognot x, x) + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + + let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + + let is_constant (z,o) = (Ints_t.logxor z o) = one_mask + + let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) + + let nabla x y= if x = Ints_t.logor x y then x else one_mask + + let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) let lognot (z,o) = (o,z) + + let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), + Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) - let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), - Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero - let shift_left (z1,o1) (z2,o2) = failwith "Not implemented" +end - let shift_right (z1,o1) (z2,o2) = failwith "Not implemented" +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct + let name () = "bitfield" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] - let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + module BArith = BitFieldArith (Ints_t) - let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = top () + let bot_of ik = bot () - let nabla x y= if x = Ints_t.logor x y then x else one_mask - let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) - let zero = of_int Ints_t.zero - let one = of_int Ints_t.one - - let topbool = join zero one + let range ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in - let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2 && Ints_t.equal o1 o2) + if impossibleBitMask <> BArith.zero_mask then + failwith "Impossible bitfield" + else - let includes (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.lognot z1 ) z2 = one_mask) && - (Ints_t.logor (Ints_t.lognot o1 ) o2 = one_mask) + let min=if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask BArith.zero_mask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - let is_constant (z,o) = (Ints_t.logxor z o) = one_mask + in + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - (* assumes that no invalid state can be reached*) - let max (z,o) = (if o < Ints_t.zero then Ints_t.neg z else o) + let max =if isSigned ik then + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - let min (z,o) = (if o < Ints_t.zero then o else Ints_t.neg z) + in (min,max) -end + + let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) -module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct - let name () = "bitfield" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] - module BArith = BitFieldArith (Ints_t) + let norm ?(suppress_ovwarn=false) ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + + let (min,max) = range ik (z,o) in + let underflow = Z.compare min min_ik < 0 in + let overflow = Z.compare max max_ik > 0 in + + let new_bitfield= + (if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint (Z.add max_ik Z.one))) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo)) + in + if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) + else (new_bitfield, {underflow=underflow; overflow=overflow}) - let top () = (Ints_t.lognot (Ints_t.zero), Ints_t.lognot (Ints_t.zero)) - let top_of ik = top () - let bot () = (Ints_t.zero, Ints_t.zero) - let bot_of ik = bot () let show t = if t = bot () then "bot" else @@ -1262,53 +1300,42 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - let join ik x y = BArith.join x y - let meet ik x y = BArith.meet x y + let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst + + let leq (x:t) (y:t) = (BArith.join x y) = y - let norm ?(suppress_ovwarn=false) ?(cast=false) ik (z,o) = - M.trace "bitfield" "norm"; - ((z,o), {underflow=false; overflow=false}) + let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) let to_int (z,o) = if is_bot (z,o) then None else if BArith.is_constant (z,o) then Some o else None - let equal_to i (u,l) = - M.trace "bitfield" "equal_to"; - if BArith.of_int i = (u,l) then `Eq - else if BArith.includes (u,l) (BArith.of_int i) then `Top + let equal_to i bf = + if BArith.of_int i = bf then `Eq + else if leq (BArith.of_int i) bf then `Top else `Neq let of_interval ?(suppress_ovwarn=false) ik (x,y) = M.trace "bitfield" "of_interval"; failwith "Not implemented" - let of_int ik (x: int_t) = (BArith.of_int x, {underflow=false; overflow=false}) - let of_bool _ik = function true -> BArith.one | false -> BArith.zero let to_bool d = - M.trace "bitfield" "to_bool"; - if not (BArith.includes d BArith.zero ) then Some true + if not (leq BArith.zero d) then Some true else if BArith.eq d BArith.zero then Some false else None - let starting ?(suppress_ovwarn=false) ik n = - M.trace "bitfield" "starting"; - (top(), {underflow=false; overflow=false}) + let starting ?(suppress_ovwarn=false) ik n = (norm ~suppress_ovwarn ik @@ BArith.of_int n) - let ending ?(suppress_ovwarn=false) ik n = - M.trace "bitfield" "ending"; - (top(), {underflow=false; overflow=false}) + let ending ?(suppress_ovwarn=false) ik n = (norm ~suppress_ovwarn ik @@ BArith.of_int n) - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = - M.trace "bitfield" "cast_to"; - norm ~cast:true t (* norm does all overflow handling *) + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t - let widen ik x y = BArith.widen x y + let widen ik x y = (norm ik @@ BArith.widen x y) |> fst let narrow ik x y = meet ik x y @@ -1337,6 +1364,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let lognot ik i1 = BArith.lognot i1 + let eq ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) + else if not (leq x y || leq y x) then of_bool ik false + else BArith.top_bool + let neg ?no_ov ik v = M.trace "bitfield" "neg"; failwith "Not implemented" @@ -1363,90 +1395,33 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int M.trace "bitfield" "rem"; top_of ik - let eq ik x y = - M.trace "bitfield" "eq"; - if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) - else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik false - else BArith.topbool - + let ne ik x y = if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) - else if not (BArith.includes x y || (BArith.includes y x)) then of_bool ik true - else BArith.topbool - - - let leq (x:t) (y:t) = BArith.includes x y - - type comparison_result = - | Less - | LessOrEqual - | Greater - | GreaterOrEqual - | Unknown - -let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = - M.trace "bitfield" "compare_bitfields"; - let bit_length = Sys.word_size - 2 in (* Set bit length based on system word size *) - let sign_bit_position = if signed then bit_length - 1 else -1 in - let result = ref Unknown in - - (* Helper function to check bits at each position *) - let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 in - - (* Iterate from Most Significant Bit (MSB) to Least Significant Bit (LSB) *) - for i = bit_length - 1 downto 0 do - let bit1_zero = get_bit z1 i in - let bit1_one = get_bit o1 i in - let bit2_zero = get_bit z2 i in - let bit2_one = get_bit o2 i in - - (* Check if bits at position i are both known *) - if (bit1_zero || bit1_one) && (bit2_zero || bit2_one) then - if bit1_zero && bit2_one then begin - result := if strict then Less else LessOrEqual; - raise Exit - end else if bit1_one && bit2_zero then begin - result := if strict then Greater else GreaterOrEqual; - raise Exit - end else if (bit1_one = bit2_one) && (bit1_zero = bit2_zero) then - () (* Equal bits, continue checking lower bits *) - else - result := Unknown (* Unknown bit situation, stop *) - else - result := Unknown; - raise Exit - done; - - (* Handle sign bit adjustment if signed *) - if signed && !result <> Unknown then - match !result with - | Less when get_bit o1 sign_bit_position <> get_bit o2 sign_bit_position -> result := Greater - | Greater when get_bit o1 sign_bit_position <> get_bit o2 sign_bit_position -> result := Less - | _ -> (); - else (); + else if not (leq x y || leq y x) then of_bool ik true + else BArith.top_bool - (* Handle non-strict inequalities for unknowns *) - if not strict && !result = Unknown then begin - if (Ints_t.logand z1 o2) = Ints_t.zero then result := LessOrEqual - else if (Ints_t.logand o1 z2) = Ints_t.zero then result := GreaterOrEqual - end; - !result + let le ik x y = failwith "Not implemented" - let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.topbool + let ge ik x y = failwith "Not implemented" - let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.topbool - let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.topbool + let gt ik x y =failwith "Not implemented" - let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.topbool + let lt ik x y =failwith "Not implemented" let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; failwith "Not implemented" let arbitrary ik = - M.trace "bitfield" "arbitrary"; - failwith "Not implemented" + let open QCheck.Iter in + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink = function + | (z, o) -> (GobQCheck.shrink pair_arb (z, o) >|= fun (z, o) -> norm ik (z, o) |> fst) + in + QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> norm ik x |> fst ) pair_arb) let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = From d42b9895552a0e6072b445bdde1ada52dbef4371 Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Thu, 7 Nov 2024 15:41:21 +0100 Subject: [PATCH 013/111] separation of break_down into break_down_to_const_bitfields and break_down_to_consts --- src/cdomain/value/cdomains/intDomain.ml | 50 +++++++++++++------------ 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index f0711dda83..f540a5f72c 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1191,13 +1191,14 @@ end -(* BitField arithmetic, without any overflow handling etc. *) -module BitFieldArith (Ints_t : IntOps.IntOps) = struct +(* Bitfield arithmetic, without any overflow handling etc. *) +module BitfieldArith (Ints_t : IntOps.IntOps) = struct let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask let is_const (z,o) = (Ints_t.logxor z o) = one_mask + let is_undefined (z,o) = Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 let of_int v = (Ints_t.lognot v, v) let to_int (z, o) = if is_const (z,o) then Some o else None @@ -1225,8 +1226,6 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct else Ints_t.logor mask one_mask - (* max number of (left or right) shifts on an ikind s.t. 0 results from it *) - (* TODO hard coded. Other impl? *) let max_shift (ik: Cil.ikind) = let ilog2 n = let rec aux n acc = @@ -1234,27 +1233,33 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct else aux (n lsr 1) (acc + 1) in aux n 0 in - Cil.bytesSizeOfInt ik * 8 |> ilog2 + Size.bit ik |> ilog2 - (* concretizes an abstract bitfield into a set of minimal bitfields that represent concrete numbers - used for shifting bitfields for an ikind in WC O( 2^(log(n)) ) with n = ikind size *) - let break_down ik (z, o) : Ints_t.t list option = - (* check if the abstract bitfield has undefined bits i.e. at some pos i the bit is neither 1 or 0 *) - if Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 - then None + let break_down_to_const_bitfields ik_size one_mask (z,o) : (Ints_t.t * Ints_t.t) list option = + if is_undefined (z,o) + then None (* cannot break down due to undefined bits *) else - let n = max_shift ik in - let zero_extend_mask = Ints_t.shift_left Ints_t.one n - |> fun x -> Ints_t.sub x Ints_t.one - |> Ints_t.lognot in - let result = ref [Ints_t.logand o zero_extend_mask] in - for i = 0 to n - 1 do + let z_masked = Int_t.logand z (Ints_t.lognot one_mask) in + let o_masked = Ints_t.logand o one_mask in + let result = ref [(z_masked, o_masked)] in + for i = 0 to ik_size - 1 do if get_bit z i = get_bit o i then let with_one = !result in - let with_zero = List.map (fun elm -> set_bit ~zero:true elm i) with_one in + let with_zero = List.map (fun (z,o) -> (set_bit ~zero:false z i, set_bit ~zero:true o i)) with_one in result := with_one @ with_zero done; - Some (!result) + Some (!result) + + (* concretizes an abstract bitfield into a set of minimal bitfields that represent concrete numbers + used for shifting bitfields for an ikind in WC O( 2^(log(n)) ) with n = ikind size *) + let break_down_to_consts ik (z, o) : Ints_t.t list option = + let n = max_shift ik in + let zero_extend_mask = Ints_t.shift_left Ints_t.one n + |> fun x -> Ints_t.sub x Ints_t.one + |> Ints_t.lognot in + match break_down_to_const_bitfields n zero_extend_mask with + | None -> None + | Some c_bf_lst = List.map snd c_bf_lst let shift ?left ik a n = let shift_by n (z, o) = @@ -1262,12 +1267,11 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let z_or_mask = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in (Ints_t.logor (Ints_t.shift_left z n) z_or_mask, Ints_t.shift_left o n) else - (Ints_t.shift_right z n, Ints_t.shift_right o n) in - if is_const (z2, o2) then shift_by (Ints_t.to_int o2) (z1, o1) |> Option.some + (Ints_t.shift_right z n, Ints_t.shift_right o n) in if is_const n then shift_by (Ints_t.to_int @@ snd n) a |> Option.some else - match break_down ik n with None -> None + match break_down_to_consts ik n with None -> None | Some c_lst -> List.map (fun c -> shift_by (Ints_t.to_int @@ snd n) a) c_lst |> List.fold_left join zero @@ -1292,7 +1296,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let name () = "bitfield" type int_t = Ints_t.t type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] - module BArith = BitFieldArith (Ints_t) + module BArith = BitfieldArith (Ints_t) let top () = (Ints_t.lognot (Ints_t.zero), Ints_t.lognot (Ints_t.zero)) From 6a266693681a77a50c8f868126034e0bed7f10f2 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Fri, 8 Nov 2024 00:59:17 +0100 Subject: [PATCH 014/111] clean up; begin other methods --- src/cdomain/value/cdomains/intDomain.ml | 149 ++++++++++++++---------- 1 file changed, 87 insertions(+), 62 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4581a1a857..1d798a43ad 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1234,7 +1234,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let bot_of ik = bot () - let range ik (z,o) = let knownBitMask = Ints_t.logxor z o in let unknownBitMask = Ints_t.lognot knownBitMask in @@ -1265,8 +1264,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int in (min,max) - let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) - + let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) let norm ?(suppress_ovwarn=false) ik (z,o) = let (min_ik, max_ik) = Size.range ik in @@ -1288,7 +1286,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) else (new_bitfield, {underflow=underflow; overflow=overflow}) - let show t = if t = bot () then "bot" else if t = top () then "top" else @@ -1300,13 +1297,15 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst let leq (x:t) (y:t) = (BArith.join x y) = y + let widen ik x y = (norm ik @@ BArith.widen x y) |> fst + let narrow ik x y = y + let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) let to_int (z,o) = if is_bot (z,o) then None else @@ -1319,8 +1318,16 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else `Neq let of_interval ?(suppress_ovwarn=false) ik (x,y) = - M.trace "bitfield" "of_interval"; - failwith "Not implemented" + (* naive implentation -> horrible O(n) runtime *) + let (min_ik, max_ik) = Size.range ik in + let result = ref (bot ()) in + let current = ref (min_ik) in + let bf = ref (bot ()) in + while Z.leq !current max_ik do + bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); + current := Z.add !current Z.one + done; + norm ~suppress_ovwarn ik !result let of_bool _ik = function true -> BArith.one | false -> BArith.zero @@ -1329,15 +1336,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else if BArith.eq d BArith.zero then Some false else None - let starting ?(suppress_ovwarn=false) ik n = (norm ~suppress_ovwarn ik @@ BArith.of_int n) - - let ending ?(suppress_ovwarn=false) ik n = (norm ~suppress_ovwarn ik @@ BArith.of_int n) - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t - let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = meet ik x y + (* Logic *) let log1 f ik i1 = match to_bool i1 with | None -> top_of ik @@ -1347,14 +1349,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | None, None -> top_of ik | None, Some x | Some x, None -> of_bool ik x | Some x, Some y -> of_bool ik (f x y) - let c_logor ik i1 i2 = log2 (||) ik i1 i2 let c_logand ik i1 i2 = log2 (&&) ik i1 i2 let c_lognot ik i1 = log1 not ik i1 - let xor a b = (a && not b) || (not a && b) + + (* Bitwise *) let logxor ik i1 i2 = BArith.logxor i1 i2 @@ -1364,37 +1366,33 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let lognot ik i1 = BArith.lognot i1 - let eq ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) - else if not (leq x y || leq y x) then of_bool ik false - else BArith.top_bool + let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) - let neg ?no_ov ik v = - M.trace "bitfield" "neg"; - failwith "Not implemented" + let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) + + let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) - let shift_right ik a b = - M.trace "bitfield" "shift_right"; - failwith "Not implemented" - let shift_left ik a b = - M.trace "bitfield" "shift_left"; - failwith "Not implemented" - - let shift_left ik a b =(top_of ik,{underflow=false; overflow=false}) + (* Arith *) let add ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - + let sub ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - + let mul ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) + + let neg ?no_ov ik v = (top_of ik,{underflow=false; overflow=false}) + + let div ?no_ov ik x y = (top_of ik,{underflow=false; overflow=false}) - let rec div ?no_ov ik x y = (top_of ik,{underflow=false; overflow=false}) + let rem ik x y = (top_of ik) - let rem ik x y = - M.trace "bitfield" "rem"; - top_of ik + (* Comparison *) + let eq ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) + else if not (leq x y || leq y x) then of_bool ik false + else BArith.top_bool let ne ik x y = if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) @@ -1405,40 +1403,67 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let ge ik x y = failwith "Not implemented" - let gt ik x y =failwith "Not implemented" let lt ik x y =failwith "Not implemented" - let invariant_ikind e ik = - M.trace "bitfield" "invariant_ikind"; - failwith "Not implemented" - - let arbitrary ik = - let open QCheck.Iter in - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink = function - | (z, o) -> (GobQCheck.shrink pair_arb (z, o) >|= fun (z, o) -> norm ik (z, o) |> fst) - in - QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> norm ik x |> fst ) pair_arb) - + let invariant_ikind e ik (z,o) = + let range = range ik (z,o) in + IntInvariant.of_interval e ik range - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - M.trace "bitfield" "refine_with_congruence"; - top_of ik + let starting ?(suppress_ovwarn=false) ik n = + if Ints_t.compare n Ints_t.zero >= 0 then + (* sign bit can only be 0, as all numbers will be positive *) + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let zs = BArith.one_mask in + let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + (norm ~suppress_ovwarn ik @@ (zs,os)) + else + (norm ~suppress_ovwarn ik @@ (top ())) - let refine_with_interval ik a b = - M.trace "bitfield" "refine_with_interval"; - top_of ik + let ending ?(suppress_ovwarn=false) ik n = + if Ints_t.compare n Ints_t.zero <= 0 then + (* sign bit can only be 1, as all numbers will be negative *) + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + let os = BArith.one_mask in + (norm ~suppress_ovwarn ik @@ (zs,os)) + else + (norm ~suppress_ovwarn ik @@ (top ())) + + let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in + match intv, cong with + | (z,o), Some (c, m) -> + if is_power_of_two m then + let congruenceMask = Ints_t.lognot m in + let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in + let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + (newz, newo) + else + top_of ik + | _ -> top_of ik - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - M.trace "bitfield" "refine_with_excl_list"; - top_of ik + let refine_with_interval ik t i = t - let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = - M.trace "bitfield" "refine_with_incl_list"; - top_of ik + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t + + let refine_with_incl_list ik t (incl : (int_t list) option) : t = + (* loop over all included ints *) + match incl with + | None -> t + | Some ls -> + List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) t ls + + let arbitrary ik = + let open QCheck.Iter in + let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb1 int_arb2 in + let shrink = function + | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) + in + QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) let project ik p t = t end From 05b3d8ec3c21f3b079249976f35b0c9ea946cf9c Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Fri, 8 Nov 2024 01:13:15 +0100 Subject: [PATCH 015/111] format --- src/cdomain/value/cdomains/intDomain.ml | 144 ++++++++++++------------ 1 file changed, 72 insertions(+), 72 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 1d798a43ad..894d0a51bd 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -90,7 +90,7 @@ module Tuple6 = struct print_e out e; BatIO.nwrite out sep; print_f out f - BatIO.nwrite out last + BatIO.nwrite out last let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = @@ -112,33 +112,33 @@ module Tuple6 = struct open BatOrd let eq eq1 eq2 eq3 eq4 eq5 eq6 = fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_eq eq1 t1 t1' - (bin_eq eq2 t2 t2' - (bin_eq eq3 t3 t3' - (bin_eq eq4 t4 t4' - (bin_eq eq5 t5 t5' eq6)))) t6 t6' + bin_eq eq1 t1 t1' + (bin_eq eq2 t2 t2' + (bin_eq eq3 t3 t3' + (bin_eq eq4 t4 t4' + (bin_eq eq5 t5 t5' eq6)))) t6 t6' let ord ord1 ord2 ord3 ord4 ord5 ord6 = fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_ord ord1 t1 t1' - (bin_ord ord2 t2 t2' - (bin_ord ord3 t3 t3' - (bin_ord ord4 t4 t4' - (bin_ord ord5 t5 t5' ord6)))) t6 t6' + bin_ord ord1 t1 t1' + (bin_ord ord2 t2 t2' + (bin_ord ord3 t3 t3' + (bin_ord ord4 t4 t4' + (bin_ord ord5 t5 t5' ord6)))) t6 t6' let comp comp1 comp2 comp3 comp4 comp5 comp6 = fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - let c1 = comp1 t1 t1' in - if c1 <> 0 then c1 else - let c2 = comp2 t2 t2' in - if c2 <> 0 then c2 else - let c3 = comp3 t3 t3' in - if c3 <> 0 then c3 else - let c4 = comp4 t4 t4' in - if c4 <> 0 then c4 else - let c5 = comp5 t5 t5' in - if c5 <> 0 then c5 else - comp6 t6 t6' + let c1 = comp1 t1 t1' in + if c1 <> 0 then c1 else + let c2 = comp2 t2 t2' in + if c2 <> 0 then c2 else + let c3 = comp3 t3 t3' in + if c3 <> 0 then c3 else + let c4 = comp4 t4 t4' in + if c4 <> 0 then c4 else + let c5 = comp5 t5 t5' in + if c5 <> 0 then c5 else + comp6 t6 t6' module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct type t = A.t * B.t * C.t * D.t * E.t * F.t @@ -1207,7 +1207,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) let lognot (z,o) = (o,z) - + let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) @@ -1244,26 +1244,26 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int failwith "Impossible bitfield" else - let min=if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask BArith.zero_mask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + let min=if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask BArith.zero_mask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - in - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + in + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - let max =if isSigned ik then - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + let max =if isSigned ik then + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + in (min,max) - in (min,max) - let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) let norm ?(suppress_ovwarn=false) ik (z,o) = @@ -1274,14 +1274,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let overflow = Z.compare max max_ik > 0 in let new_bitfield= - (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in - (newz,newo) - else - let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint (Z.add max_ik Z.one))) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in - (newz,newo)) + (if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint (Z.add max_ik Z.one))) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo)) in if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) else (new_bitfield, {underflow=underflow; overflow=overflow}) @@ -1309,8 +1309,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) let to_int (z,o) = if is_bot (z,o) then None else - if BArith.is_constant (z,o) then Some o - else None + if BArith.is_constant (z,o) then Some o + else None let equal_to i bf = if BArith.of_int i = bf then `Eq @@ -1330,7 +1330,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ~suppress_ovwarn ik !result let of_bool _ik = function true -> BArith.one | false -> BArith.zero - + let to_bool d = if not (leq BArith.zero d) then Some true else if BArith.eq d BArith.zero then Some false @@ -1350,7 +1350,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | None, Some x | Some x, None -> of_bool ik x | Some x, Some y -> of_bool ik (f x y) let c_logor ik i1 i2 = log2 (||) ik i1 i2 - + let c_logand ik i1 i2 = log2 (&&) ik i1 i2 let c_lognot ik i1 = log1 not ik i1 @@ -1369,18 +1369,18 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) - + let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) (* Arith *) let add ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - + let sub ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - + let mul ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - + let neg ?no_ov ik v = (top_of ik,{underflow=false; overflow=false}) let div ?no_ov ik x y = (top_of ik,{underflow=false; overflow=false}) @@ -1393,7 +1393,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) else if not (leq x y || leq y x) then of_bool ik false else BArith.top_bool - + let ne ik x y = if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) else if not (leq x y || leq y x) then of_bool ik true @@ -1420,7 +1420,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (norm ~suppress_ovwarn ik @@ (zs,os)) else (norm ~suppress_ovwarn ik @@ (top ())) - + let ending ?(suppress_ovwarn=false) ik n = if Ints_t.compare n Ints_t.zero <= 0 then (* sign bit can only be 1, as all numbers will be negative *) @@ -1430,7 +1430,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (norm ~suppress_ovwarn ik @@ (zs,os)) else (norm ~suppress_ovwarn ik @@ (top ())) - + let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in match intv, cong with @@ -1449,25 +1449,25 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t let refine_with_incl_list ik t (incl : (int_t list) option) : t = - (* loop over all included ints *) + (* loop over all included ints *) match incl with | None -> t | Some ls -> - List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) t ls + List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) t ls let arbitrary ik = - let open QCheck.Iter in - let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb1 int_arb2 in - let shrink = function - | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) - in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) + let open QCheck.Iter in + let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb1 int_arb2 in + let shrink = function + | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) + in + QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) let project ik p t = t end - + (** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = @@ -2821,7 +2821,7 @@ module Enums : S with type int_t = Z.t = struct let range ik = Size.range ik -(* + (* let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) @@ -3786,7 +3786,7 @@ module IntDomTupleImpl = struct | (_, _, _, Some true, _,_) | (_, _, _, _, Some true,_) | (_, _, _, _, _, Some true) - -> true + -> true | _ -> false @@ -3797,7 +3797,7 @@ module IntDomTupleImpl = struct | (_, _, _, Some false, _,_) | (_, _, _, _, Some false,_) | (_, _, _, _, _, Some false) - -> + -> false | _ -> true From 27c9876fd117a44e135f19c07ab7199d9f84c79b Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Fri, 8 Nov 2024 01:47:51 +0100 Subject: [PATCH 016/111] make it more functional. untested --- src/cdomain/value/cdomains/intDomain.ml | 55 +++++++++++-------------- 1 file changed, 24 insertions(+), 31 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index f540a5f72c..b581188c5b 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1217,49 +1217,45 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - let get_bit mask pos = ((Ints_t.to_int mask) lsr pos) land 1 = 1 - let set_bit ?(zero=false) mask pos = + let get_bit bf pos = Ints_t.logand Ints_t.one @@ Ints_t.shift_right bf (pos-1) + let set_bit ?(zero=false) bf pos = let one_mask = Ints_t.shift_left Ints_t.one pos in if zero then let zero_mask = Ints_t.lognot one_mask in - Ints_t.logand mask zero_mask + Ints_t.logand bf zero_mask else - Ints_t.logor mask one_mask + Ints_t.logor bf one_mask - let max_shift (ik: Cil.ikind) = + let max_shift ik = let ilog2 n = let rec aux n acc = if n <= 1 then acc else aux (n lsr 1) (acc + 1) in aux n 0 - in + in Size.bit ik |> ilog2 - let break_down_to_const_bitfields ik_size one_mask (z,o) : (Ints_t.t * Ints_t.t) list option = + let break_down_to_const_bitfields ik_size one_mask (z,o) = if is_undefined (z,o) - then None (* cannot break down due to undefined bits *) + then None else let z_masked = Int_t.logand z (Ints_t.lognot one_mask) in let o_masked = Ints_t.logand o one_mask in - let result = ref [(z_masked, o_masked)] in - for i = 0 to ik_size - 1 do - if get_bit z i = get_bit o i then - let with_one = !result in - let with_zero = List.map (fun (z,o) -> (set_bit ~zero:false z i, set_bit ~zero:true o i)) with_one in - result := with_one @ with_zero - done; - Some (!result) - - (* concretizes an abstract bitfield into a set of minimal bitfields that represent concrete numbers - used for shifting bitfields for an ikind in WC O( 2^(log(n)) ) with n = ikind size *) - let break_down_to_consts ik (z, o) : Ints_t.t list option = + let rec break_down c_lst i = + if i < ik_size then + if get_bit z i = get_bit o i then + with_zero = List.map (fun (z,o) -> (set_bit z i, set_bit ~zero:true o i)) c_lst in + break_down (c_lst @ with_zero) (i+1) + else + break_down c_lst (i+1) + else c_lst + in break_down [(z_masked, o_masked)] 0 |> Option.some + + let break_down_to_consts ik (z, o) = let n = max_shift ik in - let zero_extend_mask = Ints_t.shift_left Ints_t.one n - |> fun x -> Ints_t.sub x Ints_t.one - |> Ints_t.lognot in - match break_down_to_const_bitfields n zero_extend_mask with - | None -> None - | Some c_bf_lst = List.map snd c_bf_lst + let zero_extend_mask = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one + in + Option.map (List.map snd) (break_down_to_const_bitfields n zero_extend_mask) let shift ?left ik a n = let shift_by n (z, o) = @@ -1271,11 +1267,8 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in if is_const n then shift_by (Ints_t.to_int @@ snd n) a |> Option.some else - match break_down_to_consts ik n with None -> None - | Some c_lst -> - List.map (fun c -> shift_by (Ints_t.to_int @@ snd n) a) c_lst - |> List.fold_left join zero - |> Option.some + break_down_to_consts ik n + |> Option.map (fun c_lst -> List.map (fun c -> shift_by c a) c_lst |> List.fold_left join zero) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) From ca7c04059b9bc977b49ac86a820599bd4b652dcb Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Fri, 8 Nov 2024 04:23:10 +0100 Subject: [PATCH 017/111] bug fix: Bitfields with z set to zero missed --- src/cdomain/value/cdomains/intDomain.ml | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index b581188c5b..37a19d1791 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1235,21 +1235,23 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in Size.bit ik |> ilog2 - let break_down_to_const_bitfields ik_size one_mask (z,o) = + let break_down_to_const_bitfields ik_size suffix_mask (z,o) = if is_undefined (z,o) then None else - let z_masked = Int_t.logand z (Ints_t.lognot one_mask) in - let o_masked = Ints_t.logand o one_mask in + let z_prefix = Int_t.logand z (Ints_t.lognot suffix_mask) in + let o_suffix = Ints_t.logand o suffix_mask in let rec break_down c_lst i = if i < ik_size then if get_bit z i = get_bit o i then - with_zero = List.map (fun (z,o) -> (set_bit z i, set_bit ~zero:true o i)) c_lst in - break_down (c_lst @ with_zero) (i+1) + List.fold_left2 ( + fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc + ) [] c_lst c_lst + |> fun c_lst -> break_down c_lst (i+1) else break_down c_lst (i+1) else c_lst - in break_down [(z_masked, o_masked)] 0 |> Option.some + in break_down [(z_prefix, o_suffix)] 0 |> Option.some let break_down_to_consts ik (z, o) = let n = max_shift ik in @@ -1257,7 +1259,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in Option.map (List.map snd) (break_down_to_const_bitfields n zero_extend_mask) - let shift ?left ik a n = + let shift ?left ik bf n = let shift_by n (z, o) = if left then let z_or_mask = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one @@ -1265,10 +1267,10 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else (Ints_t.shift_right z n, Ints_t.shift_right o n) in - if is_const n then shift_by (Ints_t.to_int @@ snd n) a |> Option.some + if is_const n then shift_by (Ints_t.to_int @@ snd n) bf |> Option.some else break_down_to_consts ik n - |> Option.map (fun c_lst -> List.map (fun c -> shift_by c a) c_lst |> List.fold_left join zero) + |> Option.map (fun c_lst -> List.map (fun c -> shift_by c bf) c_lst |> List.fold_left join zero) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) @@ -1387,14 +1389,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int M.trace "bitfield" "neg"; failwith "Not implemented" - (*TODO no overflow handling for shifts?*) - (*TODO move shift impl here due to dependancy to ikind?*) + (*TODO norming*) let shift_right ik a b = M.trace "bitfield" "shift_right"; match BArith.shift ~left:false ik a b with | None -> (bot (), {underflow=false; overflow=false}) | Some x -> (x, {underflow=false; overflow=false}) + (*TODO norming*) let shift_left ik a b = M.trace "bitfield" "shift_left"; match BArith.shift ~left:true ik a b with From 1338d6555b8ad8714cbacfe41870f1722e7eaad8 Mon Sep 17 00:00:00 2001 From: AdrianKrauss <49120283+AdrianKrauss@users.noreply.github.com> Date: Tue, 12 Nov 2024 10:06:47 +0100 Subject: [PATCH 018/111] Implementation of arithmetic operators (including neg) (#8) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * implemented modulo * current changes * implementation of add, sub, mul based on paper * implemented neg * bug fixes for arith operators --------- Co-authored-by: Adrian Krauß --- src/cdomain/value/cdomains/intDomain.ml | 113 ++++++++++++++++++++---- 1 file changed, 95 insertions(+), 18 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5cac3d727b..35a35c70a5 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1233,9 +1233,15 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let is_constant (z,o) = (Ints_t.logxor z o) = one_mask (* assumes that no invalid state can be reached*) - let max (z,o) = (if o < Ints_t.zero then Ints_t.neg z else o) + let max ik (z,o) = + let z_cast = Size.cast ik (Ints_t.to_bigint (Ints_t.lognot z)) in + let o_cast = Size.cast ik (Ints_t.to_bigint z) in + Z.max z_cast o_cast - let min (z,o) = (if o < Ints_t.zero then o else Ints_t.neg z) + let min ik (z,o) = + let z_cast = Size.cast ik (Ints_t.to_bigint (Ints_t.lognot z)) in + let o_cast = Size.cast ik (Ints_t.to_bigint z) in + Z.min z_cast o_cast end @@ -1337,10 +1343,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let lognot ik i1 = BArith.lognot i1 - let neg ?no_ov ik v = - M.trace "bitfield" "neg"; - failwith "Not implemented" - let shift_right ik a b = M.trace "bitfield" "shift_right"; failwith "Not implemented" @@ -1351,17 +1353,85 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_left ik a b =(top_of ik,{underflow=false; overflow=false}) - let add ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - - let sub ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) - - let mul ?no_ov ik (z1, o1) (z2, o2) = (top_of ik,{underflow=false; overflow=false}) + (* + add, sub and mul based on the paper + "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" + of Vishwanathan et al. + *) - let rec div ?no_ov ik x y = (top_of ik,{underflow=false; overflow=false}) + let add ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let sv = Ints_t.add pv qv in + let sm = Ints_t.add pm qm in + let sigma = Ints_t.add sv sm in + let chi = Ints_t.logxor sigma sv in + let mu = Ints_t.logor (Ints_t.logor pm qm) chi in + let rv = Ints_t.logand sv (Ints_t.lognot mu) in + let rm = mu in + let o3 = Ints_t.logor rv rm in + let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + ((z3, o3),{underflow=false; overflow=false}) + + let sub ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let dv = Ints_t.sub pv qv in + let alpha = Ints_t.add dv pm in + let beta = Ints_t.sub dv qm in + let chi = Ints_t.logxor alpha beta in + let mu = Ints_t.logor (Ints_t.logor pm qm) chi in + let rv = Ints_t.logand dv (Ints_t.lognot mu) in + let rm = mu in + let o3 = Ints_t.logor rv rm in + let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + ((z3, o3),{underflow=false; overflow=false}) + + let mul ?no_ov ik (z1, o1) (z2, o2) = + let z1 = ref z1 in + let o1 = ref o1 in + let z2 = ref z2 in + let o2 = ref o2 in + let z3 = ref BArith.one_mask in + let o3 = ref BArith.zero_mask in + for i = Size.bit ik downto 0 do + if Ints_t.logand !o1 Ints_t.one == Ints_t.one then + if Ints_t.logand !z1 Ints_t.one == Ints_t.one then + let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in + z3 := Ints_t.logor !z3 tmp; + o3 := Ints_t.logor !o3 tmp + else + let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in + z3 := fst tmp; + o3 := snd tmp + ; + z1 := Ints_t.shift_right !z1 1; + o1 := Ints_t.shift_right !o1 1; + z2 := Ints_t.shift_left !z2 1; + o2 := Ints_t.shift_left !o2 1; + done; + ((!z3, !o3),{underflow=false; overflow=false}) + + let rec div ?no_ov ik (z1, o1) (z2, o2) = + if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) + else (top_of ik,{underflow=false; overflow=false}) let rem ik x y = M.trace "bitfield" "rem"; - top_of ik + if BArith.is_constant x && BArith.is_constant y then ( + (* x % y = x - (x / y) * y *) + let tmp = fst (div ik x y) in + let tmp = fst (mul ik tmp y) in + fst (sub ik x tmp)) + else top_of ik + + let neg ?no_ov ik x = + M.trace "bitfield" "neg"; + sub ?no_ov ik BArith.zero x let eq ik x y = M.trace "bitfield" "eq"; @@ -1432,13 +1502,21 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = end; !result - let ge ik x y = if compare_bitfields x y = GreaterOrEqual then of_bool ik true else BArith.topbool + let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true + else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false + else BArith.topbool - let le ik x y = if compare_bitfields x y = LessOrEqual then of_bool ik true else BArith.topbool + let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false + else BArith.topbool - let gt ik x y = if compare_bitfields x y = Greater then of_bool ik true else BArith.topbool + let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true + else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false + else BArith.topbool - let lt ik x y = if compare_bitfields x y = Less then of_bool ik true else BArith.topbool + let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false + else BArith.topbool let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; @@ -1448,7 +1526,6 @@ let compare_bitfields ?(strict=true) ?(signed=false) (z1,o1) (z2,o2) = M.trace "bitfield" "arbitrary"; failwith "Not implemented" - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = M.trace "bitfield" "refine_with_congruence"; top_of ik From 447db3d95e5f3a0ed7e351a2dfbed3460de0f125 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 12 Nov 2024 16:34:16 +0100 Subject: [PATCH 019/111] fix comments --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 894d0a51bd..d4dffb20e1 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1279,7 +1279,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in (newz,newo) else - let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint (Z.add max_ik Z.one))) in + let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in (newz,newo)) in @@ -1422,7 +1422,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (norm ~suppress_ovwarn ik @@ (top ())) let ending ?(suppress_ovwarn=false) ik n = - if Ints_t.compare n Ints_t.zero <= 0 then + if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then (* sign bit can only be 1, as all numbers will be negative *) let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in From 89294a9d22c450847efa6236619f0210af412f76 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 12 Nov 2024 17:00:17 +0100 Subject: [PATCH 020/111] delete bitfield ml --- src/analyses/bitfield.ml | 211 --------------------------------------- 1 file changed, 211 deletions(-) delete mode 100644 src/analyses/bitfield.ml diff --git a/src/analyses/bitfield.ml b/src/analyses/bitfield.ml deleted file mode 100644 index 7b53d2c647..0000000000 --- a/src/analyses/bitfield.ml +++ /dev/null @@ -1,211 +0,0 @@ -(** Simplest possible analysis with unit domain ([unit]). *) - -open GoblintCil -open Analyses - - -module Bitfield= struct - module I = IntDomain.Flattened - - type t = I.t * I.t - -(* abstract operators from the paper *) - - let of_int (z:Z.t) : t = (I.lognot @@ I.of_int (Z.to_int64 z), I.of_int (Z.to_int64 z)) - - let logneg (p:t) :t = let (z,o) = p in (o,z) - - let logand (p1:t) (p2:t) :t = let (z1,o1) = p1 in let (z2,o2) = p2 in (I.logor z1 z2, I.logand o1 o2) - - let logor (p1:t) (p2:t) :t = let (z1,o1) = p1 in let (z2,o2) = p2 in (I.logand z1 z2, I.logor o1 o2) - - let logxor (p1:t) (p2:t) :t = let (z1,o1) = p1 in let (z2,o2) = p2 in (I.logor (I.logand z1 (I.lognot o2)) (I.logand (I.lognot o1) o2), I.logor (I.logand o1 (I.lognot o2)) (I.logand (I.lognot o1) o2)) - - let logshiftleft (p1:t) (p2:t) :t = failwith "Not implemented" - - let logshiftright (p1:t) (p2:t) :t = failwith "Not implemented" - - - let join (z1,o1) (z2,o2) = - (I.logor z1 z2, I.logor o1 o2) - - let meet (z1,o1) (z2,o2) = let nabla x y= (if x = I.logor x y then y else (I.of_int (Z.to_int64 (Z.minus_one) ))) in - (nabla z1 z2, nabla o1 o2) - - (* todo wrap *) - - - let equal (z1,o1) (z2,o2) = z1 = z2 && o1 = o2 - let hash (z,o) = I.hash z + 31 * I.hash o - let compare (z1,o1) (z2,o2) = - match compare z1 z2 with - | 0 -> compare o1 o2 - | c -> c - - let show (z,o) = Printf.sprintf "Bitfield{z:%s,o:%s}" (I.show z) (I.show o) - - let pretty () (z,o) = Pretty.dprintf "Bitfield{z:%s,o:%s}" (I.show z) (I.show o) - let printXml out(z,o) = BatPrintf.fprintf out "%a%a" I.printXml z I.printXml o - - let name () = "Bitfield" - - let to_yojson (z,o) = I.to_yojson z (*TODO*) - - - let tag (z,o) = Hashtbl.hash (z,o) - let arbitrary () = QCheck.pair (I.arbitrary ()) (I.arbitrary ()) - let relift x = x - - let leq (z1,o1) (z2,o2) = I.leq z1 z2 && I.leq o1 o2 - - - let widen (z1,o1) (z2,o2) = if I.leq z1 z2 && I.leq o1 o2 then (z2, o2) else (I.top (), I.top ()) - - let narrow = meet - - let pretty_diff () ((z1,o1),(z2,o2)) = - Pretty.dprintf "Bitfield: (%s,%s) not leq (%s,%s)" (I.show z1) (I.show o1) (I.show z2) (I.show o2) - - - - let top () : t = (I.of_int (Z.to_int64 (Z.minus_one)), I.of_int (Z.to_int64 (Z.minus_one))) - let bot () : t = (I.of_int (Z.to_int64 Z.zero), I.of_int (Z.to_int64 Z.zero)) - let is_top (e:t) = e = top () - let is_bot (e:t) = e = bot () -end - - - -(* module Spec : Analyses.MCPSpec with module D = Lattice.Unit and module C = Printable.Unit and type marshal = unit = *) -(* No signature so others can override module G *) -module Spec = -struct - include Analyses.DefaultSpec - - module B = Bitfield - - let name () = "bitfield" - module D = MapDomain.MapBot (Basetype.Variables) (B) - include Analyses.ValueContexts(D) - - - - let is_integer_var (v: varinfo) = - match v.vtype with - | TInt _ -> true - | _ -> false - - - let get_local = function - | Var v, NoOffset when is_integer_var v && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) - | _, _ -> None - - let rec eval (state : D.t) (e: exp) = - match e with - | Const c -> (match c with - | CInt (i,_,_) -> - (try B.of_int i with Z.Overflow -> B.top ()) - (* Our underlying int domain here can not deal with values that do not fit into int64 *) - (* Use Z.to_int64 instead of Cilint.int64_of_cilint to get exception instead of silent wrap-around *) - | _ -> B.top () - - - - ) - | Lval (Var x, NoOffset) when is_integer_var x && not (x.vglob || x.vaddrof) -> - (try D.find x state with Not_found -> B.top ()) - | _ -> B.top () - - - (* Map of integers variables to our signs lattice. *) - (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - print_endline "assign"; - - let d = ctx.local in - match lval with - | (Var x, NoOffset) -> - (* Convert the raw tuple to a proper Bitfield.t value *) - let v = eval d rval in - D.add x v d - | _ -> d - - let branch ctx (exp:exp) (tv:bool) : D.t = - print_endline "branch"; - let d = ctx.local in - match exp with - | BinOp (Eq, e1, e2, _) -> - (match e1, e2 with - | Lval (Var x, NoOffset), Const (CInt (i,_,_)) when is_integer_var x && not (x.vglob || x.vaddrof) -> - let v = eval d e2 in - if tv then - D.add x v d else - D.add x (B.logneg v) d - | _ -> d - ) - - | _ -> d - - - let body ctx (f:fundec) : D.t = - print_endline "body"; - ctx.local - - let return ctx (exp:exp option) (f:fundec) : D.t = - print_endline "return"; - ctx.local - - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - print_endline "enter"; - [ctx.local, ctx.local] - - - let assert_holds (d: D.t) (e:exp) = - print_endline "assert_holds"; - match e with - | BinOp (Eq, e1, e2, _) -> - (match e1, e2 with - | BinOp (BAnd, a,b,_), Const (CInt (i,_,_)) -> - let pl=eval d a in - let pr=eval d b in - let and_result=B.logand pl pr in - B.equal and_result (B.of_int i) - | _ -> false - ) -| _ -> false - - -let query ctx (type a) (q: a Queries.t): a Queries.result = - print_endline "query"; - let open Queries in - match q with - | EvalInt e when assert_holds ctx.local e -> - let ik = Cilfacade.get_ikind_exp e in - ID.of_bool ik true - | _ -> Result.top q - - - let combine_env ctx lval fexp f args fc au f_ask = - print_endline "combine_env"; - au - - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = - print_endline "combine_assign"; - ctx.local - - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - let d = ctx.local in - match lval with - | Some (Var x, NoOffset) -> D.add x( B.top ()) d - | _ -> d - - - - let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.top ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local - let exitstate v = D.top () -end - -let _ = - MCP.register_analysis (module Spec : MCPSpec) From c78510b98339d51285ad4635700988ed048a5916 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 12 Nov 2024 17:01:31 +0100 Subject: [PATCH 021/111] fix --- src/cdomain/value/cdomains/intDomain.ml | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index ee877b4287..e78db58ea1 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1221,7 +1221,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in let guaranteedBits = Ints_t.logand o knownBitMask in - if impossibleBitMask <> BArith.zero_mask then + if impossibleBitMask <> zero_mask then failwith "Impossible bitfield" else @@ -1230,7 +1230,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask BArith.zero_mask in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) let max ik (z,o) = @@ -1239,10 +1239,13 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in let guaranteedBits = Ints_t.logand o knownBitMask in - if impossibleBitMask <> BArith.zero_mask then + if impossibleBitMask <> zero_mask then failwith "Impossible bitfield" else + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + if isSigned ik then Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) else @@ -1470,19 +1473,19 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false - else BArith.topbool + else BArith.top_bool let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false - else BArith.topbool + else BArith.top_bool let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false - else BArith.topbool + else BArith.top_bool let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false - else BArith.topbool + else BArith.top_bool let invariant_ikind e ik (z,o) = @@ -1544,10 +1547,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) - match incl with + let incl_list_masks = match incl with | None -> t | Some ls -> - List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) t ls + List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls + in + BArith.meet t incl_list_masks let arbitrary ik = let open QCheck.Iter in From 1adccde24a6a4dff228c8836a101f47ee0d217e2 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 12 Nov 2024 17:18:15 +0100 Subject: [PATCH 022/111] hotfix refinements --- src/cdomain/value/cdomains/intDomain.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index e78db58ea1..32c86ccf09 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1535,15 +1535,15 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = M.trace "bitfield" "refine_with_congruence"; - top_of ik + t let refine_with_interval ik a b = M.trace "bitfield" "refine_with_interval"; - top_of ik + t let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = M.trace "bitfield" "refine_with_excl_list"; - top_of ik + t let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) From 2e05197f14f2b8cbe7e18af27118887596d73d7e Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 12 Nov 2024 17:19:11 +0100 Subject: [PATCH 023/111] . --- tests/unit/cdomains/intDomainTest.ml | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index a60b7a6cb1..b1cab10b80 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -320,6 +320,25 @@ struct ] end + +module BitfieldTest (B : IntDomain.SOverflow with type int_t = Z.t) = +struct + module B = IntDomain.SOverflowUnlifter (B) + let ik = Cil.IInt + let i65536 = B.of_Bitfield + let i65537 = I.of_interval ik (Z.zero, of_int 65537) + let imax = I.of_interval ik (Z.zero, of_int 2147483647) + let imin = I.of_interval ik (of_int (-2147483648), Z.zero) +end + +module Bitfield = BitfieldTest(IntDomain.Bitfield) + + +module test = +struct + module B = IntDomain.Bitfield + B. +end let test () = "intDomainTest" >::: [ "int_Integers" >::: A.test (); From 897d6a2970debdc16761f11b40ad66e80353a07c Mon Sep 17 00:00:00 2001 From: Giancarlo Calvache Date: Tue, 12 Nov 2024 17:28:14 +0100 Subject: [PATCH 024/111] bitfield shifts pr ready --- src/cdomain/value/cdomains/intDomain.ml | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 37a19d1791..57a9cbd755 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1235,14 +1235,16 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in Size.bit ik |> ilog2 - let break_down_to_const_bitfields ik_size suffix_mask (z,o) = + let break_down_log ik (z,o) = if is_undefined (z,o) then None else + let n = max_shift ik in + let suffix_mask = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in let z_prefix = Int_t.logand z (Ints_t.lognot suffix_mask) in let o_suffix = Ints_t.logand o suffix_mask in let rec break_down c_lst i = - if i < ik_size then + if i < n then if get_bit z i = get_bit o i then List.fold_left2 ( fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc @@ -1253,11 +1255,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else c_lst in break_down [(z_prefix, o_suffix)] 0 |> Option.some - let break_down_to_consts ik (z, o) = - let n = max_shift ik in - let zero_extend_mask = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one - in - Option.map (List.map snd) (break_down_to_const_bitfields n zero_extend_mask) + let break_down ik bf = Option.map (List.map snd) (break_down_log ik bf) let shift ?left ik bf n = let shift_by n (z, o) = @@ -1269,7 +1267,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in if is_const n then shift_by (Ints_t.to_int @@ snd n) bf |> Option.some else - break_down_to_consts ik n + break_down ik n |> Option.map (fun c_lst -> List.map (fun c -> shift_by c bf) c_lst |> List.fold_left join zero) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) @@ -1392,16 +1390,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (*TODO norming*) let shift_right ik a b = M.trace "bitfield" "shift_right"; - match BArith.shift ~left:false ik a b with - | None -> (bot (), {underflow=false; overflow=false}) - | Some x -> (x, {underflow=false; overflow=false}) + norm ik @@ BArith.shift ~left:false ik a b |> Option.value ~default: (bot ()) (*TODO norming*) let shift_left ik a b = M.trace "bitfield" "shift_left"; - match BArith.shift ~left:true ik a b with - | None -> (bot (), {underflow=false; overflow=false}) - | Some x -> (x, {underflow=false; overflow=false}) + norm ik @@ BArith.shift ~left:true ik a b |> Option.value ~default: (bot ()) let add ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) let mul ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) From 257cc5ba0fece36c308045456ab4765a3abfe98d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 12 Nov 2024 19:58:40 +0100 Subject: [PATCH 025/111] added norm to almost every function which usess ikind --- tests/regression/82-bitfield/01-simple.c | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 tests/regression/82-bitfield/01-simple.c diff --git a/tests/regression/82-bitfield/01-simple.c b/tests/regression/82-bitfield/01-simple.c new file mode 100644 index 0000000000..04527f7945 --- /dev/null +++ b/tests/regression/82-bitfield/01-simple.c @@ -0,0 +1,10 @@ +//PARAM: --enable ana.int.bitfield --set sem.int.signed_overflow assume_none --disable ana.int.def_exc --disable ana.int.enums +#include + +int main() { + int x; + + if (x+1) + + return 0; +} \ No newline at end of file From 24b371927d0fcac63fabb608072c9d055e360838 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 12 Nov 2024 20:00:15 +0100 Subject: [PATCH 026/111] added correct fil and deleted test file --- src/cdomain/value/cdomains/intDomain.ml | 50 ++++++++++++------------ tests/regression/82-bitfield/01-simple.c | 10 ----- 2 files changed, 25 insertions(+), 35 deletions(-) delete mode 100644 tests/regression/82-bitfield/01-simple.c diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 32c86ccf09..dc496d6719 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1265,11 +1265,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int module BArith = BitFieldArith (Ints_t) - let top () = (BArith.one_mask, BArith.one_mask) - let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = top () - let bot_of ik = bot () - let range ik bf = (BArith.min ik bf, BArith.max ik bf) let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) @@ -1294,6 +1289,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) else (new_bitfield, {underflow=underflow; overflow=overflow}) + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = (norm ik (top ())) |> fst + let bot_of ik = (norm ik (bot ())) |> fst + let show t = if t = bot () then "bot" else if t = top () then "top" else @@ -1312,7 +1312,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let leq (x:t) (y:t) = (BArith.join x y) = y let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = y + let narrow ik x y = norm ik y |> fst let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) @@ -1366,13 +1366,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (* Bitwise *) - let logxor ik i1 i2 = BArith.logxor i1 i2 + let logxor ik i1 i2 = BArith.logxor i1 i2 |> norm ik |> fst - let logand ik i1 i2 = BArith.logand i1 i2 + let logand ik i1 i2 = BArith.logand i1 i2 |> norm ik |> fst - let logor ik i1 i2 = BArith.logor i1 i2 + let logor ik i1 i2 = BArith.logor i1 i2 |> norm ik |> fst - let lognot ik i1 = BArith.lognot i1 + let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) @@ -1401,7 +1401,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rm = mu in let o3 = Ints_t.logor rv rm in let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) + norm ik (z3, o3) let sub ?no_ov ik (z1, o1) (z2, o2) = let pv = Ints_t.logand o1 (Ints_t.lognot z1) in @@ -1417,7 +1417,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rm = mu in let o3 = Ints_t.logor rv rm in let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) + norm ik (z3, o3) let neg ?no_ov ik x = M.trace "bitfield" "neg"; @@ -1439,18 +1439,18 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in z3 := fst tmp; - o3 := snd tmp - ; + o3 := snd tmp; + z1 := Ints_t.shift_right !z1 1; o1 := Ints_t.shift_right !o1 1; z2 := Ints_t.shift_left !z2 1; o2 := Ints_t.shift_left !o2 1; done; - ((!z3, !o3),{underflow=false; overflow=false}) + norm ik (!z3, !o3) let rec div ?no_ov ik (z1, o1) (z2, o2) = - if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) - else (top_of ik,{underflow=false; overflow=false}) + let res = if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let tmp = Ints_t.div z1 z2 in (tmp, Ints_t.lognot tmp)) else top_of ik in + norm ik res let rem ik x y = M.trace "bitfield" "rem"; @@ -1520,14 +1520,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let congruenceMask = Ints_t.lognot m in let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - (newz, newo) + norm ik (newz, newo) |> fst else top_of ik | _ -> top_of ik - let refine_with_interval ik t i = t + let refine_with_interval ik t i = norm ik t |> fst - let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; @@ -1535,15 +1535,15 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = M.trace "bitfield" "refine_with_congruence"; - t + norm ik intv |> fst - let refine_with_interval ik a b = + let refine_with_interval ik t interval = M.trace "bitfield" "refine_with_interval"; - t + norm ik t |> fst let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = M.trace "bitfield" "refine_with_excl_list"; - t + norm ik intv |> fst let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) @@ -1552,7 +1552,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | Some ls -> List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls in - BArith.meet t incl_list_masks + meet ik t incl_list_masks let arbitrary ik = let open QCheck.Iter in diff --git a/tests/regression/82-bitfield/01-simple.c b/tests/regression/82-bitfield/01-simple.c deleted file mode 100644 index 04527f7945..0000000000 --- a/tests/regression/82-bitfield/01-simple.c +++ /dev/null @@ -1,10 +0,0 @@ -//PARAM: --enable ana.int.bitfield --set sem.int.signed_overflow assume_none --disable ana.int.def_exc --disable ana.int.enums -#include - -int main() { - int x; - - if (x+1) - - return 0; -} \ No newline at end of file From cbfbf28c38ee8cd619dca12861cd5572346e3226 Mon Sep 17 00:00:00 2001 From: Giancarlo Calvache Date: Tue, 12 Nov 2024 20:48:51 +0100 Subject: [PATCH 027/111] bug fix: signedness with right shift considered --- src/cdomain/value/cdomains/intDomain.ml | 67 +++++++++++++------------ 1 file changed, 34 insertions(+), 33 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 57a9cbd755..74afd885d5 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1198,7 +1198,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let one_mask = Ints_t.lognot zero_mask let is_const (z,o) = (Ints_t.logxor z o) = one_mask - let is_undefined (z,o) = Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 + let is_undef (z,o) = Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 let of_int v = (Ints_t.lognot v, v) let to_int (z, o) = if is_const (z,o) then Some o else None @@ -1232,43 +1232,46 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct if n <= 1 then acc else aux (n lsr 1) (acc + 1) in aux n 0 - in - Size.bit ik |> ilog2 + in ilog2 (Size.bit ik) - let break_down_log ik (z,o) = - if is_undefined (z,o) - then None + let break_down_log ik (z,o) = if is_undef (z,o) then None + else + let n = max_shift ik in + let rec break_down c_lst i = if i >= n then c_lst else - let n = max_shift ik in - let suffix_mask = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in - let z_prefix = Int_t.logand z (Ints_t.lognot suffix_mask) in - let o_suffix = Ints_t.logand o suffix_mask in - let rec break_down c_lst i = - if i < n then - if get_bit z i = get_bit o i then - List.fold_left2 ( - fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc - ) [] c_lst c_lst - |> fun c_lst -> break_down c_lst (i+1) - else - break_down c_lst (i+1) - else c_lst - in break_down [(z_prefix, o_suffix)] 0 |> Option.some + if get_bit z i = get_bit o i then + List.fold_left2 ( + fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc + ) [] c_lst c_lst + |> fun c_lst -> break_down c_lst (i+1) + else + break_down c_lst (i+1) + in + let sfx_mask = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in + break_down [(Ints_t.logand z (Ints_t.lognot sfx_msk), Ints_t.logand o sfx_msk)] 0 |> Option.some let break_down ik bf = Option.map (List.map snd) (break_down_log ik bf) - let shift ?left ik bf n = - let shift_by n (z, o) = - if left then - let z_or_mask = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one - in (Ints_t.logor (Ints_t.shift_left z n) z_or_mask, Ints_t.shift_left o n) + let shift_right ik bf n_bf = + let shift_right bf (z,o) = + let sign_msk = Ints_t.shift_left one_mask (Size.bit ik - n) in + if isSigned ik then + (Ints_t.shift_right z n, Ints_t.logor (Ints_t.shift_right o n) sign_msk) else - (Ints_t.shift_right z n, Ints_t.shift_right o n) - in - if is_const n then shift_by (Ints_t.to_int @@ snd n) bf |> Option.some + (Ints_t.logor (Ints_t.shift_right z n) sign_msk, Ints_t.shift_right o n) + in + if is_const n_bf then Some (shift_right bf (Ints_t.to_int @@ snd n_bf)) else - break_down ik n - |> Option.map (fun c_lst -> List.map (fun c -> shift_by c bf) c_lst |> List.fold_left join zero) + Option.map (fun c_lst -> List.map (shift_right bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) + + let shift_left ik bf n_bf = + let shift_left bf (z,o) = + let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one + in (Ints_t.logor (Ints_t.shift_left z n) z_msk, Ints_t.shift_left o n) + in + if is_const n then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) + else + Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) @@ -1401,8 +1404,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let mul ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) let sub ?no_ov ik x y=(top_of ik,{underflow=false; overflow=false}) - let shift_left ik a b =(top_of ik,{underflow=false; overflow=false}) - let rem ik x y = M.trace "bitfield" "rem"; top_of ik From ff8c4c7fa6b4f149262c57f5322186b88c1543a7 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Thu, 14 Nov 2024 20:24:01 +0100 Subject: [PATCH 028/111] refine hotfix2 --- src/cdomain/value/cdomains/intDomain.ml | 8654 +++++++++++------------ 1 file changed, 4327 insertions(+), 4327 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 32c86ccf09..4788e5e64c 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1,4327 +1,4327 @@ -open GobConfig -open GoblintCil -open Pretty -open PrecisionUtil - -module M = Messages - -let (%) = Batteries.(%) -let (|?) = Batteries.(|?) - -exception IncompatibleIKinds of string -exception Unknown -exception Error -exception ArithmeticOnIntegerBot of string - - - -(* Custom Tuple6 as Batteries only provides up to Tuple5 *) -module Tuple6 = struct - type ('a,'b,'c,'d,'e,'f) t = 'a * 'b * 'c * 'd * 'e * 'f - - type 'a enumerable = 'a * 'a * 'a * 'a * 'a * 'a - - let make a b c d e f= (a, b, c, d, e, f) - - let first (a,_,_,_,_, _) = a - let second (_,b,_,_,_, _) = b - let third (_,_,c,_,_, _) = c - let fourth (_,_,_,d,_, _) = d - let fifth (_,_,_,_,e, _) = e - let sixth (_,_,_,_,_, f) = f - - let map f1 f2 f3 f4 f5 f6 (a,b,c,d,e,f) = - let a = f1 a in - let b = f2 b in - let c = f3 c in - let d = f4 d in - let e = f5 e in - let f = f6 f in - (a, b, c, d, e, f) - - let mapn fn (a,b,c,d,e,f) = - let a = fn a in - let b = fn b in - let c = fn c in - let d = fn d in - let e = fn e in - let f = fn f in - (a, b, c, d, e, f) - - let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) - let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) - let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) - let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) - let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) - let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) - - - - - let curry fn a b c d e f= fn (a,b,c,d,e,f) - let uncurry fn (a,b,c,d,e,f) = fn a b c d e f - - let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) - - let of_enum e = match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some a -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some b -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some c -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some d -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some e -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some f -> (a,b,c,d,e,f) - - let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e print_f out (a,b,c,d,e,f) = - BatIO.nwrite out first; - print_a out a; - BatIO.nwrite out sep; - print_b out b; - BatIO.nwrite out sep; - print_c out c; - BatIO.nwrite out sep; - print_d out d; - BatIO.nwrite out sep; - print_e out e; - BatIO.nwrite out sep; - print_f out f - BatIO.nwrite out last - - - let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = - print ~first ~sep ~last printer printer printer printer printer out pair - - let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) ?(cmp6=Pervasives.compare) (a1,a2,a3,a4,a5,a6) (b1,b2,b3,b4,b5,b6) = - let c1 = cmp1 a1 b1 in - if c1 <> 0 then c1 else - let c2 = cmp2 a2 b2 in - if c2 <> 0 then c2 else - let c3 = cmp3 a3 b3 in - if c3 <> 0 then c3 else - let c4 = cmp4 a4 b4 in - if c4 <> 0 then c4 else - let c5 = cmp5 a5 b5 in - if c5 <> 0 then c5 else - cmp5 a6 b6 - - open BatOrd - let eq eq1 eq2 eq3 eq4 eq5 eq6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_eq eq1 t1 t1' - (bin_eq eq2 t2 t2' - (bin_eq eq3 t3 t3' - (bin_eq eq4 t4 t4' - (bin_eq eq5 t5 t5' eq6)))) t6 t6' - - let ord ord1 ord2 ord3 ord4 ord5 ord6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_ord ord1 t1 t1' - (bin_ord ord2 t2 t2' - (bin_ord ord3 t3 t3' - (bin_ord ord4 t4 t4' - (bin_ord ord5 t5 t5' ord6)))) t6 t6' - - let comp comp1 comp2 comp3 comp4 comp5 comp6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - let c1 = comp1 t1 t1' in - if c1 <> 0 then c1 else - let c2 = comp2 t2 t2' in - if c2 <> 0 then c2 else - let c3 = comp3 t3 t3' in - if c3 <> 0 then c3 else - let c4 = comp4 t4 t4' in - if c4 <> 0 then c4 else - let c5 = comp5 t5 t5' in - if c5 <> 0 then c5 else - comp6 t6 t6' - - module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let eq = eq A.eq B.eq C.eq D.eq E.eq F.eq - end - - module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord ) (F : Ord) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let ord = ord A.ord B.ord C.ord D.ord E.ord F.ord - end - - module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp ) (F : Comp) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let compare = comp A.compare B.compare C.compare D.compare E.compare F.compare - end -end - - - -(** Define records that hold mutable variables representing different Configuration values. - * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) -type ana_int_config_values = { - mutable interval_threshold_widening : bool option; - mutable interval_narrow_by_meet : bool option; - mutable def_exc_widen_by_join : bool option; - mutable interval_threshold_widening_constants : string option; - mutable refinement : string option; -} - -let ana_int_config: ana_int_config_values = { - interval_threshold_widening = None; - interval_narrow_by_meet = None; - def_exc_widen_by_join = None; - interval_threshold_widening_constants = None; - refinement = None; -} - -let get_interval_threshold_widening () = - if ana_int_config.interval_threshold_widening = None then - ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); - Option.get ana_int_config.interval_threshold_widening - -let get_interval_narrow_by_meet () = - if ana_int_config.interval_narrow_by_meet = None then - ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); - Option.get ana_int_config.interval_narrow_by_meet - -let get_def_exc_widen_by_join () = - if ana_int_config.def_exc_widen_by_join = None then - ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); - Option.get ana_int_config.def_exc_widen_by_join - -let get_interval_threshold_widening_constants () = - if ana_int_config.interval_threshold_widening_constants = None then - ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); - Option.get ana_int_config.interval_threshold_widening_constants - -let get_refinement () = - if ana_int_config.refinement = None then - ana_int_config.refinement <- Some (get_string "ana.int.refinement"); - Option.get ana_int_config.refinement - - - -(** Whether for a given ikind, we should compute with wrap-around arithmetic. - * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) -let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" - -(** Whether for a given ikind, we should assume there are no overflows. - * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) -let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" - -let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds -let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) - -type overflow_info = { overflow: bool; underflow: bool;} - -let set_overflow_flag ~cast ~underflow ~overflow ik = - if !AnalysisState.executing_speculative_computations then - (* Do not produce warnings when the operations are not actually happening in code *) - () - else - let signed = Cil.isSigned ik in - if !AnalysisState.postsolving && signed && not cast then - AnalysisState.svcomp_may_overflow := true; - let sign = if signed then "Signed" else "Unsigned" in - match underflow, overflow with - | true, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign - | true, false -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign - | false, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign - | false, false -> assert false - -let reset_lazy () = - ResettableLazy.reset widening_thresholds; - ResettableLazy.reset widening_thresholds_desc; - ana_int_config.interval_threshold_widening <- None; - ana_int_config.interval_narrow_by_meet <- None; - ana_int_config.def_exc_widen_by_join <- None; - ana_int_config.interval_threshold_widening_constants <- None; - ana_int_config.refinement <- None - -module type Arith = -sig - type t - val neg: t -> t - val add: t -> t -> t - val sub: t -> t -> t - val mul: t -> t -> t - val div: t -> t -> t - val rem: t -> t -> t - - val lt: t -> t -> t - val gt: t -> t -> t - val le: t -> t -> t - val ge: t -> t -> t - val eq: t -> t -> t - val ne: t -> t -> t - - val lognot: t -> t - val logand: t -> t -> t - val logor : t -> t -> t - val logxor: t -> t -> t - - val shift_left : t -> t -> t - val shift_right: t -> t -> t - - val c_lognot: t -> t - val c_logand: t -> t -> t - val c_logor : t -> t -> t - -end - -module type ArithIkind = -sig - type t - val neg: Cil.ikind -> t -> t - val add: Cil.ikind -> t -> t -> t - val sub: Cil.ikind -> t -> t -> t - val mul: Cil.ikind -> t -> t -> t - val div: Cil.ikind -> t -> t -> t - val rem: Cil.ikind -> t -> t -> t - - val lt: Cil.ikind -> t -> t -> t - val gt: Cil.ikind -> t -> t -> t - val le: Cil.ikind -> t -> t -> t - val ge: Cil.ikind -> t -> t -> t - val eq: Cil.ikind -> t -> t -> t - val ne: Cil.ikind -> t -> t -> t - - val lognot: Cil.ikind -> t -> t - val logand: Cil.ikind -> t -> t -> t - val logor : Cil.ikind -> t -> t -> t - val logxor: Cil.ikind -> t -> t -> t - - val shift_left : Cil.ikind -> t -> t -> t - val shift_right: Cil.ikind -> t -> t -> t - - val c_lognot: Cil.ikind -> t -> t - val c_logand: Cil.ikind -> t -> t -> t - val c_logor : Cil.ikind -> t -> t -> t - -end - -(* Shared functions between S and Z *) -module type B = -sig - include Lattice.S - type int_t - val bot_of: Cil.ikind -> t - val top_of: Cil.ikind -> t - val to_int: t -> int_t option - val equal_to: int_t -> t -> [`Eq | `Neq | `Top] - - val to_bool: t -> bool option - val to_excl_list: t -> (int_t list * (int64 * int64)) option - val of_excl_list: Cil.ikind -> int_t list -> t - val is_excl_list: t -> bool - - val to_incl_list: t -> int_t list option - - val maximal : t -> int_t option - val minimal : t -> int_t option - - val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t -end - -(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) -module type IkindUnawareS = -sig - include B - include Arith with type t := t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: int_t -> t - val of_bool: bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val arbitrary: unit -> t QCheck.arbitrary - val invariant: Cil.exp -> t -> Invariant.t -end - -(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) -module type S = -sig - include B - include ArithIkind with type t:= t - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val neg : ?no_ov:bool -> Cil.ikind -> t -> t - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t - - val join: Cil.ikind -> t -> t -> t - val meet: Cil.ikind -> t -> t -> t - val narrow: Cil.ikind -> t -> t -> t - val widen: Cil.ikind -> t -> t -> t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val is_top_of: Cil.ikind -> t -> bool - val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t - - val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t - val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t - - val project: Cil.ikind -> int_precision -> t -> t - val arbitrary: Cil.ikind -> t QCheck.arbitrary -end - -module type SOverflow = -sig - - include S - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val of_int : Cil.ikind -> int_t -> t * overflow_info - - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - - val shift_left : Cil.ikind -> t -> t -> t * overflow_info - - val shift_right : Cil.ikind -> t -> t -> t * overflow_info -end - -module type Y = -sig - (* include B *) - include B - include Arith with type t:= t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val is_top_of: Cil.ikind -> t -> bool - - val project: int_precision -> t -> t - val invariant: Cil.exp -> t -> Invariant.t -end - -module type Z = Y with type int_t = Z.t - - -module IntDomLifter (I : S) = -struct - open Cil - type int_t = I.int_t - type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] - - let ikind {ikind; _} = ikind - - (* Helper functions *) - let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) - let lift op x = {x with v = op x.ikind x.v } - (* For logical operations the result is of type int *) - let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} - let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } - let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} - - let bot_of ikind = { v = I.bot_of ikind; ikind} - let bot () = failwith "bot () is not implemented for IntDomLifter." - let is_bot x = I.is_bot x.v - let top_of ikind = { v = I.top_of ikind; ikind} - let top () = failwith "top () is not implemented for IntDomLifter." - let is_top x = I.is_top x.v - - (* Leq does not check for ikind, because it is used in invariant with arguments of different type. - TODO: check ikinds here and fix invariant to work with right ikinds *) - let leq x y = I.leq x.v y.v - let join = lift2 I.join - let meet = lift2 I.meet - let widen = lift2 I.widen - let narrow = lift2 I.narrow - - let show x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - "⊤" - else - I.show x.v (* TODO add ikind to output *) - let pretty () x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - Pretty.text "⊤" - else - I.pretty () x.v (* TODO add ikind to output *) - let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) - let printXml o x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - BatPrintf.fprintf o "\n\n⊤\n\n\n" - else - I.printXml o x.v (* TODO add ikind to output *) - (* This is for debugging *) - let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" - let to_yojson x = I.to_yojson x.v - let invariant e x = - let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in - I.invariant_ikind e' x.ikind x.v - let tag x = I.tag x.v - let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." - let to_int x = I.to_int x.v - let of_int ikind x = { v = I.of_int ikind x; ikind} - let equal_to i x = I.equal_to i x.v - let to_bool x = I.to_bool x.v - let of_bool ikind b = { v = I.of_bool ikind b; ikind} - let to_excl_list x = I.to_excl_list x.v - let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} - let is_excl_list x = I.is_excl_list x.v - let to_incl_list x = I.to_incl_list x.v - let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} - let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} - let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} - let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} - let maximal x = I.maximal x.v - let minimal x = I.minimal x.v - - let neg = lift I.neg - let add = lift2 I.add - let sub = lift2 I.sub - let mul = lift2 I.mul - let div = lift2 I.div - let rem = lift2 I.rem - let lt = lift2_cmp I.lt - let gt = lift2_cmp I.gt - let le = lift2_cmp I.le - let ge = lift2_cmp I.ge - let eq = lift2_cmp I.eq - let ne = lift2_cmp I.ne - let lognot = lift I.lognot - let logand = lift2 I.logand - let logor = lift2 I.logor - let logxor = lift2 I.logxor - let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) - let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) - let c_lognot = lift_logical I.c_lognot - let c_logand = lift2 I.c_logand - let c_logor = lift2 I.c_logor - - let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} - - let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v - - let relift x = { v = I.relift x.v; ikind = x.ikind } - - let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } -end - -module type Ikind = -sig - val ikind: unit -> Cil.ikind -end - -module PtrDiffIkind : Ikind = -struct - let ikind = Cilfacade.ptrdiff_ikind -end - -module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = -struct - include I - let top () = I.top_of (Ik.ikind ()) - let bot () = I.bot_of (Ik.ikind ()) -end - -module Size = struct (* size in bits as int, range as int64 *) - open Cil - let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned - - let top_typ = TInt (ILongLong, []) - let min_for x = intKindForValue x (sign x = `Unsigned) - let bit = function (* bits needed for representation *) - | IBool -> 1 - | ik -> bytesSizeOfInt ik * 8 - let is_int64_big_int x = Z.fits_int64 x - let card ik = (* cardinality *) - let b = bit ik in - Z.shift_left Z.one b - let bits ik = (* highest bits for neg/pos values *) - let s = bit ik in - if isSigned ik then s-1, s-1 else 0, s - let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) - let range ik = - let a,b = bits ik in - let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in - let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) - x,y - - let is_cast_injective ~from_type ~to_type = - let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in - let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in - if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; - Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 - - let cast t x = (* TODO: overflow is implementation-dependent! *) - if t = IBool then - (* C11 6.3.1.2 Boolean type *) - if Z.equal x Z.zero then Z.zero else Z.one - else - let a,b = range t in - let c = card t in - let y = Z.erem x c in - let y = if Z.gt y b then Z.sub y c - else if Z.lt y a then Z.add y c - else y - in - if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); - y - - let min_range_sign_agnostic x = - let size ik = - let a,b = bits_i64 ik in - Int64.neg a,b - in - if sign x = `Signed then - size (min_for x) - else - let a, b = size (min_for x) in - if b <= 64L then - let upper_bound_less = Int64.sub b 1L in - let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in - if x <= max_one_less then - a, upper_bound_less - else - a,b - else - a, b - - (* From the number of bits used to represent a positive value, determines the maximal representable value *) - let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) - - (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) - let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) - -end - - -module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct - open B - (* these should be overwritten for better precision if possible: *) - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let starting ?(suppress_ovwarn=false) ik x = top_of ik - let ending ?(suppress_ovwarn=false) ik x = top_of ik - let maximal x = None - let minimal x = None -end - -module Std (B: sig - type t - val name: unit -> string - val top_of: Cil.ikind -> t - val bot_of: Cil.ikind -> t - val show: t -> string - val equal: t -> t -> bool - end) = struct - include Printable.StdLeaf - let name = B.name (* overwrite the one from Printable.Std *) - open B - let is_top x = failwith "is_top not implemented for IntDomain.Std" - let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind - This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) - let is_top_of ik x = B.equal x (top_of ik) - - (* all output is based on B.show *) - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) - let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y - - include StdTop (B) -end - -(* Textbook interval arithmetic, without any overflow handling etc. *) -module IntervalArith (Ints_t : IntOps.IntOps) = struct - let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) - let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) - - let mul (x1, x2) (y1, y2) = - let x1y1 = (Ints_t.mul x1 y1) in - let x1y2 = (Ints_t.mul x1 y2) in - let x2y1 = (Ints_t.mul x2 y1) in - let x2y2 = (Ints_t.mul x2 y2) in - (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) - - let shift_left (x1,x2) (y1,y2) = - let y1p = Ints_t.shift_left Ints_t.one y1 in - let y2p = Ints_t.shift_left Ints_t.one y2 in - mul (x1, x2) (y1p, y2p) - - let div (x1, x2) (y1, y2) = - let x1y1n = (Ints_t.div x1 y1) in - let x1y2n = (Ints_t.div x1 y2) in - let x2y1n = (Ints_t.div x2 y1) in - let x2y2n = (Ints_t.div x2 y2) in - let x1y1p = (Ints_t.div x1 y1) in - let x1y2p = (Ints_t.div x1 y2) in - let x2y1p = (Ints_t.div x2 y1) in - let x2y2p = (Ints_t.div x2 y2) in - (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) - - let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) - let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) - - let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) - - let one = (Ints_t.one, Ints_t.one) - let zero = (Ints_t.zero, Ints_t.zero) - let top_bool = (Ints_t.zero, Ints_t.one) - - let to_int (x1, x2) = - if Ints_t.equal x1 x2 then Some x1 else None - - let upper_threshold u max_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - let max_ik' = Ints_t.to_bigint max_ik in - let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in - BatOption.map_default Ints_t.of_bigint max_ik t - let lower_threshold l min_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - let min_ik' = Ints_t.to_bigint min_ik in - let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in - BatOption.map_default Ints_t.of_bigint min_ik t - let is_upper_threshold u = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - List.exists (Z.equal u) ts - let is_lower_threshold l = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - List.exists (Z.equal l) ts -end - -module IntInvariant = -struct - let of_int e ik x = - if get_bool "witness.invariant.exact" then - Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) - else - Invariant.none - - let of_incl_list e ik ps = - match ps with - | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> - assert (List.mem Z.zero ps); - assert (List.mem Z.one ps); - Invariant.none - | [_] when get_bool "witness.invariant.exact" -> - Invariant.none - | _ :: _ :: _ - | [_] | [] -> - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in - Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) (Invariant.bot ()) ps - - let of_interval_opt e ik = function - | (Some x1, Some x2) when Z.equal x1 x2 -> - of_int e ik x1 - | x1_opt, x2_opt -> - let (min_ik, max_ik) = Size.range ik in - let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in - let i1 = - match x1_opt, inexact_type_bounds with - | Some x1, false when Z.equal min_ik x1 -> Invariant.none - | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) - | None, _ -> Invariant.none - in - let i2 = - match x2_opt, inexact_type_bounds with - | Some x2, false when Z.equal x2 max_ik -> Invariant.none - | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) - | None, _ -> Invariant.none - in - Invariant.(i1 && i2) - - let of_interval e ik (x1, x2) = - of_interval_opt e ik (Some x1, Some x2) - - let of_excl_list e ik ns = - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in - Invariant.(a && i) - ) (Invariant.top ()) ns -end - -module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = -struct - let name () = "intervals" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - module IArith = IntervalArith (Ints_t) - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - let top_of ik = Some (range ik) - let bot () = None - let bot_of ik = bot () (* TODO: improve *) - - let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) -> - if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> - if Ints_t.compare x y > 0 then - (None,{underflow=false; overflow=false}) - else ( - let (min_ik, max_ik) = range ik in - let underflow = Ints_t.compare min_ik x > 0 in - let overflow = Ints_t.compare max_ik y < 0 in - let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in - let v = - if underflow || overflow then - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in - let resdiff = Ints_t.abs (Ints_t.sub y x) in - if Ints_t.compare resdiff diff > 0 then - top_of ik - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if Ints_t.compare l u <= 0 then - Some (l, u) - else - (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) - top_of ik - else if not cast && should_ignore_overflow ik then - let tl, tu = BatOption.get @@ top_of ik in - Some (Ints_t.max tl x, Ints_t.min tu y) - else - top_of ik - else - Some (x,y) - in - (v, ov_info) - ) - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst - - let meet ik (x:t) y = - match x, y with - | None, z | z, None -> None - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst - - (* TODO: change to_int signature so it returns a big_int *) - let to_int x = Option.bind x (IArith.to_int) - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) - let of_int ik (x: int_t) = of_interval ik (x,x) - let zero = Some IArith.zero - let one = Some IArith.one - let top_bool = Some IArith.top_bool - - let of_bool _ik = function true -> one | false -> zero - let to_bool (a: t) = match a with - | None -> None - | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) - - (* TODO: change signature of maximal, minimal to return big_int*) - let maximal = function None -> None | Some (x,y) -> Some y - let minimal = function None -> None | Some (x,y) -> Some x - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) - - let widen ik x y = - match x, y with - | None, z | z, None -> z - | Some (l0,u0), Some (l1,u1) -> - let (min_ik, max_ik) = range ik in - let threshold = get_interval_threshold_widening () in - let l2 = - if Ints_t.compare l0 l1 = 0 then l0 - else if threshold then IArith.lower_threshold l1 min_ik - else min_ik - in - let u2 = - if Ints_t.compare u0 u1 = 0 then u0 - else if threshold then IArith.upper_threshold u1 max_ik - else max_ik - in - norm ik @@ Some (l2,u2) |> fst - let widen ik x y = - let r = widen ik x y in - if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; - assert (leq x y); (* TODO: remove for performance reasons? *) - r - - let narrow ik x y = - match x, y with - | _,None | None, _ -> None - | Some (x1,x2), Some (y1,y2) -> - let threshold = get_interval_threshold_widening () in - let (min_ik, max_ik) = range ik in - let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in - let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in - norm ik @@ Some (lr,ur) |> fst - - - let narrow ik x y = - if get_interval_narrow_by_meet () then - meet ik x y - else - narrow ik x y - - let log f ~annihilator ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, _ when x = annihilator -> of_bool ik annihilator - | _, Some y when y = annihilator -> of_bool ik annihilator - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) ~annihilator:true - let c_logand = log (&&) ~annihilator:false - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let bit f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - let bitcomp f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let logxor = bit (fun _ik -> Ints_t.logxor) - - let logand ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) - | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst - | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst - | _ -> top_of ik - - let logor = bit (fun _ik -> Ints_t.logor) - - let bit1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_int i1 with - | Some x -> of_int ik (f ik x) |> fst - | _ -> top_of ik - - let lognot = bit1 (fun _ik -> Ints_t.lognot) - let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) - - let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) - - let binary_op_with_norm ?no_ov op ik x y = match x, y with - | None, None -> (None, {overflow=false; underflow= false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some x, Some y -> norm ik @@ Some (op x y) - - let add ?no_ov = binary_op_with_norm IArith.add - let mul ?no_ov = binary_op_with_norm IArith.mul - let sub ?no_ov = binary_op_with_norm IArith.sub - - let shift_left ik a b = - match is_bot a, is_bot b with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) - | _ -> - match a, minimal b, maximal b with - | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> - (try - let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in - norm ik @@ Some r - with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let rem ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (xl, xu), Some (yl, yu) -> - if is_top_of ik x && is_top_of ik y then - (* This is needed to preserve soundness also on things bigger than int32 e.g. *) - (* x: 3803957176L -> T in Interval32 *) - (* y: 4209861404L -> T in Interval32 *) - (* x % y: 3803957176L -> T in Interval32 *) - (* T in Interval32 is [-2147483648,2147483647] *) - (* the code below computes [-2147483647,2147483647] for this though which is unsound *) - top_of ik - else - (* If we have definite values, Ints_t.rem will give a definite result. - * Otherwise we meet with a [range] the result can be in. - * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. - * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) - let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in - let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in - let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range - - let rec div ?no_ov ik x y = - match x, y with - | None, None -> (bot (),{underflow=false; overflow=false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | (Some (x1,x2) as x), (Some (y1,y2) as y) -> - begin - let is_zero v = Ints_t.compare v Ints_t.zero = 0 in - match y1, y2 with - | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) - | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) - | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) - | _ -> binary_op_with_norm IArith.div ik x y - end - - let ne ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik true - else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then - of_bool ik false - else top_bool - - let eq ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then - of_bool ik true - else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik false - else top_bool - - let ge ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 then of_bool ik true - else if Ints_t.compare x2 y1 < 0 then of_bool ik false - else top_bool - - let le ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 <= 0 then of_bool ik true - else if Ints_t.compare y2 x1 < 0 then of_bool ik false - else top_bool - - let gt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 then of_bool ik true - else if Ints_t.compare x2 y1 <= 0 then of_bool ik false - else top_bool - - let lt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 < 0 then of_bool ik true - else if Ints_t.compare y2 x1 <= 0 then of_bool ik false - else top_bool - - let invariant_ikind e ik = function - | Some (x1, x2) -> - let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in - IntInvariant.of_interval e ik (x1', x2') - | None -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink = function - | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) - | None -> empty - in - QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) - - let modulo n k = - let result = Ints_t.rem n k in - if Ints_t.compare result Ints_t.zero >= 0 then result - else Ints_t.add result k - - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None - else if Ints_t.equal m Ints_t.zero then - Some (c, c) - else - let (min_ik, max_ik) = range ik in - let rcx = - if Ints_t.equal x min_ik then x else - Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in - let lcy = - if Ints_t.equal y max_ik then y else - Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in - if Ints_t.compare rcx lcy > 0 then None - else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst - else norm ik @@ Some (rcx, lcy) |> fst - | _ -> None - - let refine_with_congruence ik x y = - let refn = refine_with_congruence ik x y in - if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; - refn - - let refine_with_interval ik a b = meet ik a b - - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - match intv, excl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls, (rl, rh)) -> - let rec shrink op b = - let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in - if not (Ints_t.equal b new_b) then shrink op new_b else new_b - in - let (min_ik, max_ik) = range ik in - let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in - let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in - let intv' = norm ik @@ Some (l', u') |> fst in - let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in - meet ik intv' range - - let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = - match intv, incl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls) -> - let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in - let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in - match min None ls, max None ls with - | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) - | _, _-> intv - - let project ik p t = t -end - -module BitFieldArith (Ints_t : IntOps.IntOps) = struct - let zero_mask = Ints_t.zero - let one_mask = Ints_t.lognot zero_mask - - let of_int x = (Ints_t.lognot x, x) - let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - - let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) - - let is_constant (z,o) = (Ints_t.logxor z o) = one_mask - - let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) - - let nabla x y= if x = Ints_t.logor x y then x else one_mask - - let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) - - let lognot (z,o) = (o,z) - - let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), - Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) - - let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) - - let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) - - let min ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - let max ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - - if isSigned ik then - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - - let one = of_int Ints_t.one - let zero = of_int Ints_t.zero - let top_bool = join one zero - -end - -module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct - let name () = "bitfield" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] - - module BArith = BitFieldArith (Ints_t) - - let top () = (BArith.one_mask, BArith.one_mask) - let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = top () - let bot_of ik = bot () - - let range ik bf = (BArith.min ik bf, BArith.max ik bf) - - let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) - - let norm ?(suppress_ovwarn=false) ik (z,o) = - let (min_ik, max_ik) = Size.range ik in - - let (min,max) = range ik (z,o) in - let underflow = Z.compare min min_ik < 0 in - let overflow = Z.compare max max_ik > 0 in - - let new_bitfield= - (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in - (newz,newo) - else - let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in - (newz,newo)) - in - if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) - else (new_bitfield, {underflow=underflow; overflow=overflow}) - - let show t = - if t = bot () then "bot" else - if t = top () then "top" else - let (z,o) = t in - if BArith.is_constant t then - Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) - else - Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst - - let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst - - let leq (x:t) (y:t) = (BArith.join x y) = y - - let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = y - - let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) - - let to_int (z,o) = if is_bot (z,o) then None else - if BArith.is_constant (z,o) then Some o - else None - - let equal_to i bf = - if BArith.of_int i = bf then `Eq - else if leq (BArith.of_int i) bf then `Top - else `Neq - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - (* naive implentation -> horrible O(n) runtime *) - let (min_ik, max_ik) = Size.range ik in - let result = ref (bot ()) in - let current = ref (min_ik) in - let bf = ref (bot ()) in - while Z.leq !current max_ik do - bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); - current := Z.add !current Z.one - done; - norm ~suppress_ovwarn ik !result - - let of_bool _ik = function true -> BArith.one | false -> BArith.zero - - let to_bool d = - if not (leq BArith.zero d) then Some true - else if BArith.eq d BArith.zero then Some false - else None - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t - - - (* Logic *) - - let log1 f ik i1 = match to_bool i1 with - | None -> top_of ik - | Some x -> of_bool ik (f x) - - let log2 f ik i1 i2 = match (to_bool i1, to_bool i2) with - | None, None -> top_of ik - | None, Some x | Some x, None -> of_bool ik x - | Some x, Some y -> of_bool ik (f x y) - let c_logor ik i1 i2 = log2 (||) ik i1 i2 - - let c_logand ik i1 i2 = log2 (&&) ik i1 i2 - - let c_lognot ik i1 = log1 not ik i1 - - - (* Bitwise *) - - let logxor ik i1 i2 = BArith.logxor i1 i2 - - let logand ik i1 i2 = BArith.logand i1 i2 - - let logor ik i1 i2 = BArith.logor i1 i2 - - let lognot ik i1 = BArith.lognot i1 - - let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) - - let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) - - - (* Arith *) - - (* - add, sub and mul based on the paper - "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" - of Vishwanathan et al. - *) - - let add ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in - let sv = Ints_t.add pv qv in - let sm = Ints_t.add pm qm in - let sigma = Ints_t.add sv sm in - let chi = Ints_t.logxor sigma sv in - let mu = Ints_t.logor (Ints_t.logor pm qm) chi in - let rv = Ints_t.logand sv (Ints_t.lognot mu) in - let rm = mu in - let o3 = Ints_t.logor rv rm in - let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) - - let sub ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in - let dv = Ints_t.sub pv qv in - let alpha = Ints_t.add dv pm in - let beta = Ints_t.sub dv qm in - let chi = Ints_t.logxor alpha beta in - let mu = Ints_t.logor (Ints_t.logor pm qm) chi in - let rv = Ints_t.logand dv (Ints_t.lognot mu) in - let rm = mu in - let o3 = Ints_t.logor rv rm in - let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) - - let neg ?no_ov ik x = - M.trace "bitfield" "neg"; - sub ?no_ov ik BArith.zero x - - let mul ?no_ov ik (z1, o1) (z2, o2) = - let z1 = ref z1 in - let o1 = ref o1 in - let z2 = ref z2 in - let o2 = ref o2 in - let z3 = ref BArith.one_mask in - let o3 = ref BArith.zero_mask in - for i = Size.bit ik downto 0 do - if Ints_t.logand !o1 Ints_t.one == Ints_t.one then - if Ints_t.logand !z1 Ints_t.one == Ints_t.one then - let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in - z3 := Ints_t.logor !z3 tmp; - o3 := Ints_t.logor !o3 tmp - else - let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in - z3 := fst tmp; - o3 := snd tmp - ; - z1 := Ints_t.shift_right !z1 1; - o1 := Ints_t.shift_right !o1 1; - z2 := Ints_t.shift_left !z2 1; - o2 := Ints_t.shift_left !o2 1; - done; - ((!z3, !o3),{underflow=false; overflow=false}) - - let rec div ?no_ov ik (z1, o1) (z2, o2) = - if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) - else (top_of ik,{underflow=false; overflow=false}) - - let rem ik x y = - M.trace "bitfield" "rem"; - if BArith.is_constant x && BArith.is_constant y then ( - (* x % y = x - (x / y) * y *) - let tmp = fst (div ik x y) in - let tmp = fst (mul ik tmp y) in - fst (sub ik x tmp)) - else top_of ik - - let eq ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) - else if not (leq x y || leq y x) then of_bool ik false - else BArith.top_bool - - let ne ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) - else if not (leq x y || leq y x) then of_bool ik true - else BArith.top_bool - - let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true - else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false - else BArith.top_bool - - let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true - else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false - else BArith.top_bool - - let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true - else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false - else BArith.top_bool - - let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true - else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false - else BArith.top_bool - - - let invariant_ikind e ik (z,o) = - let range = range ik (z,o) in - IntInvariant.of_interval e ik range - - let starting ?(suppress_ovwarn=false) ik n = - if Ints_t.compare n Ints_t.zero >= 0 then - (* sign bit can only be 0, as all numbers will be positive *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let zs = BArith.one_mask in - let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) - - let ending ?(suppress_ovwarn=false) ik n = - if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then - (* sign bit can only be 1, as all numbers will be negative *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in - let os = BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) - - let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in - match intv, cong with - | (z,o), Some (c, m) -> - if is_power_of_two m then - let congruenceMask = Ints_t.lognot m in - let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in - let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - (newz, newo) - else - top_of ik - | _ -> top_of ik - - let refine_with_interval ik t i = t - - let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t - - let invariant_ikind e ik = - M.trace "bitfield" "invariant_ikind"; - failwith "Not implemented" - - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - M.trace "bitfield" "refine_with_congruence"; - t - - let refine_with_interval ik a b = - M.trace "bitfield" "refine_with_interval"; - t - - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - M.trace "bitfield" "refine_with_excl_list"; - t - - let refine_with_incl_list ik t (incl : (int_t list) option) : t = - (* loop over all included ints *) - let incl_list_masks = match incl with - | None -> t - | Some ls -> - List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls - in - BArith.meet t incl_list_masks - - let arbitrary ik = - let open QCheck.Iter in - let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb1 int_arb2 in - let shrink = function - | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) - in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) - - let project ik p t = t -end - - -(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) -module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = -struct - - module Interval = IntervalFunctor (Ints_t) - module IArith = IntervalArith (Ints_t) - - - let name () = "interval_sets" - - type int_t = Ints_t.t - - let (>.) a b = Ints_t.compare a b > 0 - let (=.) a b = Ints_t.compare a b = 0 - let (<.) a b = Ints_t.compare a b < 0 - let (>=.) a b = Ints_t.compare a b >= 0 - let (<=.) a b = Ints_t.compare a b <= 0 - let (+.) a b = Ints_t.add a b - let (-.) a b = Ints_t.sub a b - - (* - Each domain's element is guaranteed to be in canonical form. That is, each interval contained - inside the set does not overlap with each other and they are not adjacent. - *) - type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - - let top_of ik = [range ik] - - let bot () = [] - - let bot_of ik = bot () - - let show (x: t) = - let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in - List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" - - (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) - type event = Enter of Ints_t.t | Exit of Ints_t.t - - let unbox_event = function Enter x -> x | Exit x -> x - - let cmp_events x y = - (* Deliberately comparing ints first => Cannot be derived *) - let res = Ints_t.compare (unbox_event x) (unbox_event y) in - if res <> 0 then res - else - begin - match (x, y) with - | (Enter _, Exit _) -> -1 - | (Exit _, Enter _) -> 1 - | (_, _) -> 0 - end - - let interval_set_to_events (xs: t) = - List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs - - let two_interval_sets_to_events (xs: t) (ys: t) = - let xs = interval_set_to_events xs in - let ys = interval_set_to_events ys in - List.merge cmp_events xs ys - - (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap - This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) - let combined_event_list lattice_op (xs:event list) = - let l = match lattice_op with `Join -> 1 | `Meet -> 2 in - let aux (interval_count, acc) = function - | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) - | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) - in - List.fold_left aux (0, []) xs |> snd |> List.rev - - let rec events_to_intervals = function - | [] -> [] - | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) - | _ -> failwith "Invalid events list" - - let remove_empty_gaps (xs: t) = - let aux acc (l, r) = match acc with - | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' - | _ -> (l, r)::acc - in - List.fold_left aux [] xs |> List.rev - - let canonize (xs: t) = - interval_set_to_events xs |> - List.sort cmp_events |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let unop (x: t) op = match x with - | [] -> [] - | _ -> canonize @@ List.concat_map op x - - let binop (x: t) (y: t) op : t = match x, y with - | [], _ -> [] - | _, [] -> [] - | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) - - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let minimal = function - | [] -> None - | (x, _)::_ -> Some x - - let maximal = function - | [] -> None - | xs -> Some (BatList.last xs |> snd) - - let equal_to_interval i (a, b) = - if a =. b && b =. i then - `Eq - else if a <=. i && i <=. b then - `Top - else - `Neq - - let equal_to i xs = match List.map (equal_to_interval i) xs with - | [] -> failwith "unsupported: equal_to with bottom" - | [`Eq] -> `Eq - | ys when List.for_all ((=) `Neq) ys -> `Neq - | _ -> `Top - - let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = - if x >. y then - ([],{underflow=false; overflow=false}) - else - let (min_ik, max_ik) = range ik in - let underflow = min_ik >. x in - let overflow = max_ik <. y in - let v = if underflow || overflow then - begin - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (max_ik -. min_ik) in - let resdiff = Ints_t.abs (y -. x) in - if resdiff >. diff then - [range ik] - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if l <=. u then - [(l, u)] - else - (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) - [(min_ik, u); (l, max_ik)] - else if not cast && should_ignore_overflow ik then - [Ints_t.max min_ik x, Ints_t.min max_ik y] - else - [range ik] - end - else - [(x,y)] - in - if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) - - let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = - let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) - - let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> - let res = List.map op (BatList.cartesian_product x y) in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let unary_op_with_norm op (ik:ikind) (x: t) = match x with - | [] -> ([],{overflow=false; underflow=false}) - | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x - - let rec leq (xs: t) (ys: t) = - let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in - match xs, ys with - | [], _ -> true - | _, [] -> false - | (xl,xr)::xs', (yl,yr)::ys' -> - if leq_interval (xl,xr) (yl,yr) then - leq xs' ys - else if xr <. yl then - false - else - leq xs ys' - - let join ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let meet ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Meet |> - events_to_intervals - - let to_int = function - | [x] -> IArith.to_int x - | _ -> None - - let zero = [IArith.zero] - let one = [IArith.one] - let top_bool = [IArith.top_bool] - - let not_bool (x:t) = - let is_false x = equal x zero in - let is_true x = equal x one in - if is_true x then zero else if is_false x then one else top_bool - - let to_bool = function - | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false - | x -> if leq zero x then None else Some true - - let of_bool _ = function true -> one | false -> zero - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) - - let of_int ik (x: int_t) = of_interval ik (x, x) - - let lt ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <. min_y then - of_bool ik true - else if min_x >=. max_y then - of_bool ik false - else - top_bool - - let le ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <=. min_y then - of_bool ik true - else if min_x >. max_y then - of_bool ik false - else - top_bool - - let gt ik x y = not_bool @@ le ik x y - - let ge ik x y = not_bool @@ lt ik x y - - let eq ik x y = match x, y with - | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> - one - | _ -> - if is_bot (meet ik x y) then - zero - else - top_bool - - let ne ik x y = not_bool @@ eq ik x y - let interval_to_int i = Interval.to_int (Some i) - let interval_to_bool i = Interval.to_bool (Some i) - - let log f ik (i1, i2) = - match (interval_to_bool i1, interval_to_bool i2) with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - - let bit f ik (i1, i2) = - match (interval_to_int i1), (interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - - let bitcomp f ik (i1, i2) = - match (interval_to_int i1, interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) - | _, _ -> (top_of ik,{overflow=false; underflow=false}) - - let logand ik x y = - let interval_logand = bit Ints_t.logand ik in - binop x y interval_logand - - let logor ik x y = - let interval_logor = bit Ints_t.logor ik in - binop x y interval_logor - - let logxor ik x y = - let interval_logxor = bit Ints_t.logxor ik in - binop x y interval_logxor - - let lognot ik x = - let interval_lognot i = - match interval_to_int i with - | Some x -> of_int ik (Ints_t.lognot x) |> fst - | _ -> top_of ik - in - unop x interval_lognot - - let shift_left ik x y = - let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftleft - - let shift_right ik x y = - let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftright - - let c_lognot ik x = - let log1 f ik i1 = - match interval_to_bool i1 with - | Some x -> of_bool ik (f x) - | _ -> top_of ik - in - let interval_lognot = log1 not ik in - unop x interval_lognot - - let c_logand ik x y = - let interval_logand = log (&&) ik in - binop x y interval_logand - - let c_logor ik x y = - let interval_logor = log (||) ik in - binop x y interval_logor - - let add ?no_ov = binary_op_with_norm IArith.add - let sub ?no_ov = binary_op_with_norm IArith.sub - let mul ?no_ov = binary_op_with_norm IArith.mul - let neg ?no_ov = unary_op_with_norm IArith.neg - - let div ?no_ov ik x y = - let rec interval_div x (y1, y2) = begin - let top_of ik = top_of ik |> List.hd in - let is_zero v = v =. Ints_t.zero in - match y1, y2 with - | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) - | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) - | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik - | _ -> IArith.div x (y1, y2) - end - in binary_op_with_norm interval_div ik x y - - let rem ik x y = - let interval_rem (x, y) = - if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then - top_of ik - else - let (xl, xu) = x in let (yl, yu) = y in - let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in - let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in - let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit Ints_t.rem ik (x, y)) [range] - in - binop x y interval_rem - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x - - (* - narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys - *) - let narrow ik xs ys = match xs ,ys with - | [], _ -> [] | _ ,[] -> xs - | _, _ -> - let min_xs = minimal xs |> Option.get in - let max_xs = maximal xs |> Option.get in - let min_ys = minimal ys |> Option.get in - let max_ys = maximal ys |> Option.get in - let min_range,max_range = range ik in - let threshold = get_interval_threshold_widening () in - let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in - let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in - xs - |> (function (_, y)::z -> (min, y)::z | _ -> []) - |> List.rev - |> (function (x, _)::z -> (x, max)::z | _ -> []) - |> List.rev - - (* - 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. - and joins all intervals in xs assigned to the same interval in ys as one interval. - 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. - 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) - - The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. - *) - let widen ik xs ys = - let (min_ik,max_ik) = range ik in - let threshold = get_bool "ana.int.interval_threshold_widening" in - let upper_threshold (_,u) = IArith.upper_threshold u max_ik in - let lower_threshold (l,_) = IArith.lower_threshold l min_ik in - (*obtain partitioning of xs intervals according to the ys interval that includes them*) - let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= - match xs,ys with - | _, [] -> [] - | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys - | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) - | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys - in - let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in - (*merge a pair of adjacent partitions*) - let merge_pair ik (a,b) (c,d) = - let new_a = function - | None -> Some (upper_threshold b, upper_threshold b) - | Some (ax,ay) -> Some (ax, upper_threshold b) - in - let new_c = function - | None -> Some (lower_threshold d, lower_threshold d) - | Some (cx,cy) -> Some (lower_threshold d, cy) - in - if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then - [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] - else - [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] - in - let partitions_are_approaching part_left part_right = match part_left, part_right with - | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) - | _,_ -> false - in - (*merge all approaching pairs of adjacent partitions*) - let rec merge_list ik = function - | [] -> [] - | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) - | x::xs -> x :: merge_list ik xs - in - (*expands left extremity*) - let widen_left = function - | [] -> [] - | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts - | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts - | x -> x - in - (*expands right extremity*) - let widen_right x = - let map_rightmost = function - | [] -> [] - | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts - | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts - | x -> x - in - List.rev x |> map_rightmost |> List.rev - in - interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd - - let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) - - let invariant_ikind e ik xs = - List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> - let open Invariant in List.fold_left (||) (bot ()) - - let modulo n k = - let result = Ints_t.rem n k in - if result >=. Ints_t.zero then result - else result +. k - - let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = - let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =. Ints_t.zero && (c <. x || c >. y) then [] - else if m =. Ints_t.zero then - [(c, c)] - else - let (min_ik, max_ik) = range ik in - let rcx = - if x =. min_ik then x else - x +. (modulo (c -. x) (Ints_t.abs m)) in - let lcy = - if y =. max_ik then y else - y -. (modulo (y -. c) (Ints_t.abs m)) in - if rcx >. lcy then [] - else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst - else norm_interval ik (rcx, lcy) |> fst - | _ -> [] - in - List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs - - let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] - - let refine_with_incl_list ik intvs = function - | None -> intvs - | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) - - let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = - let intv1 = (min, excl -. Ints_t.one) in - let intv2 = (excl +. Ints_t.one, max) in - norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst - - let of_excl_list ik (excls: int_t list) = - let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in - let res = List.fold_left (meet ik) (top_of ik) excl_list in - res - - let refine_with_excl_list ik (intv : t) = function - | None -> intv - | Some (xs, range) -> - let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = - excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl - in - let excl_list = List.map (excl_to_intervalset ik range) xs in - List.fold_left (meet ik) intv excl_list - - let project ik p t = t - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let list_pair_arb = QCheck.small_list pair_arb in - let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in - let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list - in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) -end - -module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct - include D - - let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = fst @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = fst @@ D.shift_left ik x y - - let shift_right ik x y = fst @@ D.shift_right ik x y -end - -module IntIkind = struct let ikind () = Cil.IInt end -module Interval = IntervalFunctor (IntOps.BigIntOps) -module Bitfield = BitfieldFunctor (IntOps.BigIntOps) -module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) -module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) -module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) -struct - include Printable.Std - let name () = "integers" - type t = Ints_t.t [@@deriving eq, ord, hash] - type int_t = Ints_t.t - let top () = raise Unknown - let bot () = raise Error - let top_of ik = top () - let bot_of ik = bot () - let show (x: Ints_t.t) = Ints_t.to_string x - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) - let is_top _ = false - let is_bot _ = false - - let equal_to i x = if i > x then `Neq else `Top - let leq x y = x <= y - let join x y = if Ints_t.compare x y > 0 then x else y - let widen = join - let meet x y = if Ints_t.compare x y > 0 then y else x - let narrow = meet - - let of_bool x = if x then Ints_t.one else Ints_t.zero - let to_bool' x = x <> Ints_t.zero - let to_bool x = Some (to_bool' x) - let of_int x = x - let to_int x = Some x - - let neg = Ints_t.neg - let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) - let sub = Ints_t.sub - let mul = Ints_t.mul - let div = Ints_t.div - let rem = Ints_t.rem - let lt n1 n2 = of_bool (n1 < n2) - let gt n1 n2 = of_bool (n1 > n2) - let le n1 n2 = of_bool (n1 <= n2) - let ge n1 n2 = of_bool (n1 >= n2) - let eq n1 n2 = of_bool (n1 = n2) - let ne n1 n2 = of_bool (n1 <> n2) - let lognot = Ints_t.lognot - let logand = Ints_t.logand - let logor = Ints_t.logor - let logxor = Ints_t.logxor - let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) - let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) - let c_lognot n1 = of_bool (not (to_bool' n1)) - let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) - let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) - let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." - let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) - let invariant _ _ = Invariant.none (* TODO *) -end - -module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) -struct - include Integers(IntOps.Int64Ops) - let top () = raise Unknown - let bot () = raise Error - let leq = equal - let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y - let join x y = if equal x y then x else top () - let meet x y = if equal x y then x else bot () -end - -module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) -struct - type int_t = Base.int_t - include Lattice.FlatConf (struct - include Printable.DefaultConf - let top_name = "Unknown int" - let bot_name = "Error int" - end) (Base) - - let top_of ik = top () - let bot_of ik = bot () - - - let name () = "flat integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let starting ?(suppress_ovwarn=false) ikind x = top_of ikind - let ending ?(suppress_ovwarn=false) ikind x = top_of ikind - let maximal x = None - let minimal x = None - - let lift1 f x = match x with - | `Lifted x -> - (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> - (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) -struct - include Lattice.LiftPO (struct - include Printable.DefaultConf - let top_name = "MaxInt" - let bot_name = "MinInt" - end) (Base) - type int_t = Base.int_t - let top_of ik = top () - let bot_of ik = bot () - include StdTop (struct type nonrec t = t let top_of = top_of end) - - let name () = "lifted integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let lift1 f x = match x with - | `Lifted x -> `Lifted (f x) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> `Lifted (f x y) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Flattened = Flat (Integers (IntOps.Int64Ops)) -module Lifted = Lift (Integers (IntOps.Int64Ops)) - -module Reverse (Base: IkindUnawareS) = -struct - include Base - include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) -end - -module BISet = struct - include SetDomain.Make (IntOps.BigIntOps) - let is_singleton s = cardinal s = 1 -end - -(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) -module Exclusion = -struct - module R = Interval32 - (* We use these types for the functions in this module to make the intended meaning more explicit *) - type t = Exc of BISet.t * Interval32.t - type inc = Inc of BISet.t [@@unboxed] - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) - - let cardinality_BISet s = - Z.of_int (BISet.cardinal s) - - let leq_excl_incl (Exc (xs, r)) (Inc ys) = - (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) - let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in - let card_b = cardinality_BISet ys in - if Z.compare lower_bound_cardinality_a card_b > 0 then - false - else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) - let min_a = min_of_range r in - let max_a = max_of_range r in - GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) - - let leq (Exc (xs, r)) (Exc (ys, s)) = - let min_a, max_a = min_of_range r, max_of_range r in - let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) - if not excluded_check - then false - else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) - if R.leq r s then true - else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) - then - let min_b, max_b = min_of_range s, max_of_range s in - let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) - if Z.compare min_a min_b < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) - else - true - in - let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) - if Z.compare max_b max_a < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) - else - true - in - leq1 && (leq2 ()) - else - false - end - end -end - -module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) -struct - module S = BISet - module R = Interval32 (* range for exclusion *) - - (* Ikind used for intervals representing the domain *) - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - - type t = [ - | `Excluded of S.t * R.t - | `Definite of Z.t - | `Bot - ] [@@deriving eq, ord, hash] - type int_t = Z.t - let name () = "def_exc" - - - let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) - let top () = `Excluded (S.empty (), top_range) - let bot () = `Bot - let top_of ik = `Excluded (S.empty (), size ik) - let bot_of ik = bot () - - let show x = - let short_size x = "("^R.show x^")" in - match x with - | `Bot -> "Error int" - | `Definite x -> Z.to_string x - (* Print the empty exclusion as if it was a distinct top element: *) - | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l - (* Prepend the exclusion sets with something: *) - | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let maximal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.max_of_range r) - | `Bot -> None - - let minimal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.min_of_range r) - | `Bot -> None - - let in_range r i = - if Z.compare i Z.zero < 0 then - let lowerb = Exclusion.min_of_range r in - Z.compare lowerb i <= 0 - else - let upperb = Exclusion.max_of_range r in - Z.compare i upperb <= 0 - - let is_top x = x = top () - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Definite x -> if i = x then `Eq else `Neq - | `Excluded (s,r) -> if S.mem i s then `Neq else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function - | `Excluded (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - `Excluded (s, r) - else if ik = IBool then (* downcast to bool *) - if S.mem Z.zero s then - `Definite Z.one - else - `Excluded (S.empty(), r') - else - (* downcast: may overflow *) - (* let s' = S.map (Size.cast ik) s in *) - (* We want to filter out all i in s' where (t)x with x in r could be i. *) - (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) - (* S.diff s' s, r' *) - (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) - `Excluded (S.empty (), r') - | `Definite x -> `Definite (Size.cast ik x) - | `Bot -> `Bot - - (* Wraps definite values and excluded values according to the ikind. - * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. - * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. - *) - let norm ik v = - match v with - | `Excluded (s, r) -> - let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in - (* If no overflow occurred, just return x *) - if not possibly_overflowed then ( - v - ) - (* Else, if an overflow might have occurred but we should just ignore it *) - else if should_ignore_overflow ik then ( - let r = size ik in - (* filter out excluded elements that are not in the range *) - let mapped_excl = S.filter (in_range r) s in - `Excluded (mapped_excl, r) - ) - (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) - else if not (should_wrap ik) then ( - top_of ik - ) else ( - (* Else an overflow occurred that we should treat with wrap-around *) - let r = size ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in - match ik with - | IBool -> - begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with - | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) - | true, false -> `Definite Z.one (* Not {0} -> 1 *) - | false, true -> `Definite Z.zero (* Not {1} -> 0 *) - | true, true -> `Bot (* Not {0, 1} -> bot *) - end - | ik -> - `Excluded (mapped_excl, r) - ) - | `Definite x -> - let min, max = Size.range ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - if should_wrap ik then ( - cast_to ik v - ) - else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( - v - ) - else if should_ignore_overflow ik then ( - M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; - `Bot - ) - else ( - top_of ik - ) - | `Bot -> `Bot - - let leq x y = match (x,y) with - (* `Bot <= x is always true *) - | `Bot, _ -> true - (* Anything except bot <= bot is always false *) - | _, `Bot -> false - (* Two known values are leq whenever equal *) - | `Definite (x: int_t), `Definite y -> x = y - (* A definite value is leq all exclusion sets that don't contain it *) - | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) - (* No finite exclusion set can be leq than a definite value *) - | `Excluded (xs, xr), `Definite d -> - Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) - | `Excluded (xs,xr), `Excluded (ys,yr) -> - Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) - - let join' ?range ik x y = - match (x,y) with - (* The least upper bound with the bottom element: *) - | `Bot, x -> x - | x, `Bot -> x - (* The case for two known values: *) - | `Definite (x: int_t), `Definite y -> - (* If they're equal, it's just THAT value *) - if x = y then `Definite x - (* Unless one of them is zero, we can exclude it: *) - else - let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in - `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) - (* A known value and an exclusion set... the definite value should no - * longer be excluded: *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> - if not (in_range r x) then - let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in - `Excluded (S.remove x s, R.join a r) - else - `Excluded (S.remove x s, r) - (* For two exclusion sets, only their intersection can be excluded: *) - | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) - - let join ik = join' ik - - - let widen ik x y = - if get_def_exc_widen_by_join () then - join' ik x y - else if equal x y then - x - else - join' ~range:(size ik) ik x y - - - let meet ik x y = - match (x,y) with - (* Greatest LOWER bound with the least element is trivial: *) - | `Bot, _ -> `Bot - | _, `Bot -> `Bot - (* Definite elements are either equal or the glb is bottom *) - | `Definite x, `Definite y -> if x = y then `Definite x else `Bot - (* The glb of a definite element and an exclusion set is either bottom or - * just the element itself, if it isn't in the exclusion set *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x - (* The greatest lower bound of two exclusion sets is their union, this is - * just DeMorgans Law *) - | `Excluded (x,r1), `Excluded (y,r2) -> - let r' = R.meet r1 r2 in - let s' = S.union x y |> S.filter (in_range r') in - `Excluded (s', r') - - let narrow ik x y = x - - let of_int ik x = norm ik @@ `Definite x - let to_int x = match x with - | `Definite x -> Some x - | _ -> None - - let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) - - let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) - let of_bool = of_bool_cmp - let to_bool x = - match x with - | `Definite x -> Some (IntOps.BigIntOps.to_bool x) - | `Excluded (s,r) when S.mem Z.zero s -> Some true - | _ -> None - let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in - norm ik @@ (`Excluded (ex, r)) - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let of_excl_list t l = - let r = size t in (* elements in l are excluded from the full range of t! *) - `Excluded (List.fold_right S.add l (S.empty ()), r) - let is_excl_list l = match l with `Excluded _ -> true | _ -> false - let to_excl_list (x:t) = match x with - | `Definite _ -> None - | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) - | `Bot -> None - - let to_incl_list x = match x with - | `Definite x -> Some [x] - | `Excluded _ -> None - | `Bot -> None - - let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) - (* If the Int64 might overflow on us during computation, we instead go to top_range *) - match R.minimal r, R.maximal r with - | _ -> - let rf m = (size % Size.min_for % f) (m r) in - let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in - R.join r1 r2 - - (* Default behaviour for unary operators, simply maps the function to the - * DefExc data structure. *) - let lift1 f ik x = norm ik @@ match x with - | `Excluded (s,r) -> - let s' = S.map f s in - `Excluded (s', apply_range f r) - | `Definite x -> `Definite (f x) - | `Bot -> `Bot - - let lift2 f ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite _ - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (f x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - (* Default behaviour for binary operators that are injective in either - * argument, so that Exclusion Sets can be used: *) - let lift2_inj f ik x y = - let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in - norm ik @@ - match x,y with - (* If both are exclusion sets, there isn't anything we can do: *) - | `Excluded _, `Excluded _ -> top () - (* A definite value should be applied to all members of the exclusion set *) - | `Definite x, `Excluded (s,r) -> def_exc f x s r - (* Same thing here, but we should flip the operator to map it properly *) - | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r - (* The good case: *) - | `Definite x, `Definite y -> `Definite (f x y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The equality check: *) - let eq ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x equal to an exclusion set, if it is a member then NO otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x = y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The inequality check: *) - let ne ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x <> y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x - let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y - - let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y - let mul ?no_ov ik x y = norm ik @@ match x, y with - | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x - | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y - | `Definite a, `Excluded (s,r) - (* Integer multiplication with even numbers is not injective. *) - (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) - | _ -> lift2_inj Z.mul ik x y - let div ?no_ov ik x y = lift2 Z.div ik x y - let rem ik x y = lift2 Z.rem ik x y - - (* Comparison handling copied from Enums. *) - let handle_bot x y f = match x, y with - | `Bot, `Bot -> `Bot - | `Bot, _ - | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> f () - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let lognot = lift1 Z.lognot - - let logand ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite i -> - (* Except in two special cases *) - if Z.equal i Z.zero then - `Definite Z.zero - else if Z.equal i Z.one then - of_interval IBool (Z.zero, Z.one) - else - top () - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - norm ik @@ lift2 shift_op_big_int ik x y - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - (* TODO: lift does not treat Not {0} as true. *) - let c_logand ik x y = - match to_bool x, to_bool y with - | Some false, _ - | _, Some false -> - of_bool ik false - | _, _ -> - lift2 IntOps.BigIntOps.c_logand ik x y - let c_logor ik x y = - match to_bool x, to_bool y with - | Some true, _ - | _, Some true -> - of_bool ik true - | _, _ -> - lift2 IntOps.BigIntOps.c_logor ik x y - let c_lognot ik = eq ik (of_int ik Z.zero) - - let invariant_ikind e ik (x:t) = - match x with - | `Definite x -> - IntInvariant.of_int e ik x - | `Excluded (s, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let si = IntInvariant.of_excl_list e ik (S.elements s) in - Invariant.(ri && si) - | `Bot -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - let excluded s = from_excl ik s in - let definite x = of_int ik x in - let shrink = function - | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) - | `Bot -> empty - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map excluded (S.arbitrary ()); - 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); - 1, QCheck.always `Bot - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = a - let refine_with_interval ik a b = match a, b with - | x, Some(i) -> meet ik x (of_interval ik i) - | _ -> a - let refine_with_excl_list ik a b = match a, b with - | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) -module Enums : S with type int_t = Z.t = struct - module R = Interval32 (* range for exclusion *) - - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) - - type int_t = Z.t - let name () = "enums" - let bot () = failwith "bot () not implemented for Enums" - let top () = failwith "top () not implemented for Enums" - let bot_of ik = Inc (BISet.empty ()) - let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) - let top_of ik = - match ik with - | IBool -> top_bool - | _ -> Exc (BISet.empty (), size ik) - - let range ik = Size.range ik - - (* - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) - let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 - - let show = function - | Inc xs when BISet.is_empty xs -> "bot" - | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" - | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - (* Normalization function for enums, that handles overflows for Inc. - As we do not compute on Excl, we do not have to perform any overflow handling for it. *) - let norm ikind v = - let min, max = range ikind in - (* Whether the value v lies within the values of the specified ikind. *) - let value_in_ikind v = - Z.compare min v <= 0 && Z.compare v max <= 0 - in - match v with - | Inc xs when BISet.for_all value_in_ikind xs -> v - | Inc xs -> - if should_wrap ikind then - Inc (BISet.map (Size.cast ikind) xs) - else if should_ignore_overflow ikind then - Inc (BISet.filter value_in_ikind xs) - else - top_of ikind - | Exc (xs, r) -> - (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: - let range_in_ikind r = - R.leq r (size ikind) - in - let r_min, r_max = min_of_range r, max_of_range r in - assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) - begin match ikind with - | IBool -> - begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with - | false, false -> top_bool (* Not {} -> {0, 1} *) - | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) - | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) - | true, true -> bot_of ikind (* Not {0, 1} -> bot *) - end - | _ -> - v - end - - - let equal_to i = function - | Inc x -> - if BISet.mem i x then - if BISet.is_singleton x then `Eq - else `Top - else `Neq - | Exc (x, r) -> - if BISet.mem i x then `Neq - else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with - | Exc (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - Exc (s, r) - else if ik = IBool then (* downcast to bool *) - if BISet.mem Z.zero s then - Inc (BISet.singleton Z.one) - else - Exc (BISet.empty(), r') - else (* downcast: may overflow *) - Exc ((BISet.empty ()), r') - | Inc xs -> - let casted_xs = BISet.map (Size.cast ik) xs in - if Cil.isSigned ik && not (BISet.equal xs casted_xs) - then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) - else Inc casted_xs - - let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) - - let of_interval ?(suppress_ovwarn=false) ik (x, y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in - norm ik @@ (Exc (ex, r)) - - let join _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.union x y) - | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) - | Exc (x,r), Inc y - | Inc y, Exc (x,r) -> - let r = if BISet.is_empty y - then r - else - let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in - let range = R.join min_el_range max_el_range in - R.join r range - in - Exc (BISet.diff x y, r) - - let meet _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.inter x y) - | Exc (x,r1), Exc (y,r2) -> - let r = R.meet r1 r2 in - let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in - let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in - (* We remove those elements from the exclusion set that do not fit in the range anyway *) - let excl = BISet.union (filter_by_range x) (filter_by_range y) in - Exc (excl, r) - | Inc x, Exc (y,r) - | Exc (y,r), Inc x -> Inc (BISet.diff x y) - - let widen = join - let narrow = meet - let leq a b = - match a, b with - | Inc xs, Exc (ys, r) -> - if BISet.is_empty xs - then true - else - let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in - let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in - (* Check that the xs fit into the range r *) - Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && - (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) - BISet.for_all (fun x -> not (BISet.mem x ys)) xs - | Inc xs, Inc ys -> - BISet.subset xs ys - | Exc (xs, r), Exc (ys, s) -> - Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) - | Exc (xs, r), Inc ys -> - Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) - - let handle_bot x y f = match is_bot x, is_bot y with - | false, false -> f () - | true, false - | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | true, true -> Inc (BISet.empty ()) - - let lift1 f ikind v = norm ikind @@ match v with - | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) - | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) - | _ -> top_of ikind - - let lift2 f (ikind: Cil.ikind) u v = - handle_bot u v (fun () -> - norm ikind @@ match u, v with - | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) - | _,_ -> top_of ikind) - - let lift2 f ikind a b = - try lift2 f ikind a b with Division_by_zero -> top_of ikind - - let neg ?no_ov = lift1 Z.neg - let add ?no_ov ikind a b = - match a, b with - | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,y -> lift2 Z.add ikind x y - let sub ?no_ov = lift2 Z.sub - let mul ?no_ov ikind a b = - match a, b with - | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b - | x,y -> lift2 Z.mul ikind x y - - let div ?no_ov ikind a b = match a, b with - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | x,y -> lift2 Z.div ikind x y - - let rem = lift2 Z.rem - - let lognot = lift1 Z.lognot - let logand = lift2 Z.logand - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - handle_bot x y (fun () -> - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - lift2 shift_op_big_int ik x y) - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - - let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) - let to_bool = function - | Inc e when BISet.is_empty e -> None - | Exc (e,_) when BISet.is_empty e -> None - | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false - | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true - | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true - | _ -> None - let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None - - let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None - let of_excl_list ik xs = - let min_ik, max_ik = Size.range ik in - let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in - norm ik @@ Exc (exc, size ik) - let is_excl_list = BatOption.is_some % to_excl_list - let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let c_lognot ik x = - if is_bot x - then x - else - match to_bool x with - | Some b -> of_bool ik (not b) - | None -> top_bool - - let c_logand = lift2 IntOps.BigIntOps.c_logand - let c_logor = lift2 IntOps.BigIntOps.c_logor - let maximal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) - | Exc (excl,r) -> - let rec decrement_while_contained v = - if BISet.mem v excl - then decrement_while_contained (Z.pred v) - else v - in - let range_max = Exclusion.max_of_range r in - Some (decrement_while_contained range_max) - | _ (* bottom case *) -> None - - let minimal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) - | Exc (excl,r) -> - let rec increment_while_contained v = - if BISet.mem v excl - then increment_while_contained (Z.succ v) - else v - in - let range_min = Exclusion.min_of_range r in - Some (increment_while_contained range_min) - | _ (* bottom case *) -> None - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let eq ik x y = - handle_bot x y (fun () -> - match x, y with - | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) - | _, _ -> - if is_bot (meet ik x y) then - (* If the meet is empty, there is no chance that concrete values are equal *) - of_bool ik false - else - top_bool) - - let ne ik x y = c_lognot ik (eq ik x y) - - let invariant_ikind e ik x = - match x with - | Inc ps -> - IntInvariant.of_incl_list e ik (BISet.elements ps) - | Exc (ns, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in - Invariant.(ri && nsi) - - - let arbitrary ik = - let open QCheck.Iter in - let neg s = of_excl_list ik (BISet.elements s) in - let pos s = norm ik (Inc s) in - let shrink = function - | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) - | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map neg (BISet.arbitrary ()); - 10, QCheck.map pos (BISet.arbitrary ()); - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = - let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in - match a, b with - | Inc e, None -> bot_of ik - | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) - | _ -> a - - let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) - - let refine_with_excl_list ik a b = - match b with - | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - - let refine_with_incl_list ik a b = - match a, b with - | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) - | _ -> a - - let project ik p t = t -end - -module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = -struct - let name () = "congruences" - type int_t = Z.t - - (* represents congruence class of c mod m, None is bot *) - type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] - - let ( *: ) = Z.mul - let (+:) = Z.add - let (-:) = Z.sub - let (%:) = Z.rem - let (/:) = Z.div - let (=:) = Z.equal - let (<:) x y = Z.compare x y < 0 - let (>:) x y = Z.compare x y > 0 - let (<=:) x y = Z.compare x y <= 0 - let (>=:) x y = Z.compare x y >= 0 - (* a divides b *) - let ( |: ) a b = - if a =: Z.zero then false else (b %: a) =: Z.zero - - let normalize ik x = - match x with - | None -> None - | Some (c, m) -> - if m =: Z.zero then - if should_wrap ik then - Some (Size.cast ik c, m) - else - Some (c, m) - else - let m' = Z.abs m in - let c' = c %: m' in - if c' <: Z.zero then - Some (c' +: m', m') - else - Some (c' %: m', m') - - let range ik = Size.range ik - - let top () = Some (Z.zero, Z.one) - let top_of ik = Some (Z.zero, Z.one) - let bot () = None - let bot_of ik = bot () - - let show = function ik -> match ik with - | None -> "⟂" - | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c - | Some (c, m) -> - let a = if c =: Z.zero then "" else Z.to_string c in - let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in - let c = if a = "" || b = "" then "" else "+" in - a^c^b - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let is_top x = x = top () - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq - | Some (a, b) -> if i %: b =: a then `Top else `Neq - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero - | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 - (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 - Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) - - let leq x y = - let res = leq x y in - if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; - res - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (c1,m1), Some (c2,m2) -> - let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in - normalize ik (Some (c1, m3)) - - let join ik (x:t) y = - let res = join ik x y in - if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; - res - - - let meet ik x y = - (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) - let congruence_series a c m = - let rec next a1 c1 a2 c2 = - if a2 |: a1 then (a2, c2) - else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) - in next m Z.zero a c - in - let simple_case i c m = - if m |: (i -: c) - then Some (i, Z.zero) else None - in - match x, y with - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 - | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 - | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> - let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in - normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) - | _ -> None - - let meet ik x y = - let res = meet ik x y in - if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; - res - - let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None - let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) - let zero = Some (Z.zero, Z.zero) - let one = Some (Z.one, Z.zero) - let top_bool = top() - - let of_bool _ik = function true -> one | false -> zero - - let to_bool (a: t) = match a with - | None -> None - | x when equal zero x -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = top() - - let ending = starting - - let of_congruence ik (c,m) = normalize ik @@ Some(c,m) - - let maximal t = match t with - | Some (x, y) when y =: Z.zero -> Some x - | _ -> None - - let minimal t = match t with - | Some (x,y) when y =: Z.zero -> Some x - | _ -> None - - (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) - let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = - match x with - | None -> None - | Some (c, m) when m =: Z.zero -> - let c' = Size.cast t c in - (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) - (* We go with GCC behavior here: *) - (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) - (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) - (* Clang behaves the same but they never document that anywhere *) - Some (c', m) - | _ -> - let (min_t, max_t) = range t in - let p ikorg = - let (min_ikorg, max_ikorg) = range ikorg in - ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) - in - match torg with - | Some (Cil.TInt (ikorg, _)) when p ikorg -> - if M.tracing then M.trace "cong-cast" "some case"; - x - | _ -> top () - - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = - let pretty_bool _ x = Pretty.text (string_of_bool x) in - let res = cast_to ?torg ?no_ov t x in - if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; - res - - let widen = join - - let widen ik x y = - let res = widen ik x y in - if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; - res - - let narrow = meet - - let log f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) - let c_logand = log (&&) - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let shift_right _ _ _ = top() - - let shift_right ik x y = - let res = shift_right ik x y in - if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; - res - - let shift_left ik x y = - (* Naive primality test *) - (* let is_prime n = - let n = Z.abs n in - let rec is_prime' d = - (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) - in - not (n =: Z.one) && is_prime' (Z.of_int 2) - in *) - match x, y with - | None, None -> None - | None, _ - | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik - | Some (c, m), Some (c', m') -> - let (_, max_ik) = range ik in - if m =: Z.zero && m' =: Z.zero then - normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) - else - let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) - (* TODO: commented out because fails test with _Bool *) - (* if is_prime (m' +: Z.one) then - normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) - else *) - normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) - - let shift_left ik x y = - let res = shift_left ik x y in - if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; - res - - (* Handle unsigned overflows. - From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. - The congruence modulo b may not persist on an overflow. *) - let handle_overflow ik (c, m) = - if m =: Z.zero then - normalize ik (Some (c, m)) - else - (* Find largest m'=2^k (for some k) such that m is divisible by m' *) - let tz = Z.trailing_zeros m in - let m' = Z.shift_left Z.one tz in - - let max = (snd (Size.range ik)) +: Z.one in - if m' >=: max then - (* if m' >= 2 ^ {bitlength}, there is only one value in range *) - let c' = c %: max in - Some (c', Z.zero) - else - normalize ik (Some (c, m')) - - let mul ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) - in - match x, y with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) when no_ov -> - Some (no_ov_case (c1, m1) (c2, m2)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b ) - | _ -> top () - - let mul ?no_ov ik x y = - let res = mul ?no_ov ik x y in - if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; - res - - let neg ?(no_ov=false) ik x = - match x with - | None -> bot() - | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x - - let add ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 +: c2, Z.gcd m1 m2 - in - match (x, y) with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some a, Some b when no_ov -> - normalize ik (Some (no_ov_case a b)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b) - | _ -> top () - - - let add ?no_ov ik x y = - let res = add ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "add : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) - - - let sub ?no_ov ik x y = - let res = sub ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let lognot ik x = match x with - | None -> None - | Some (c, m) -> - if (Cil.isSigned ik) then - sub ik (neg ik x) one - else - let (_, max_ik) = range ik in - Some (Z.sub max_ik c, m) - - (** The implementation of the bit operations could be improved based on the master’s thesis - 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. - see: http://www.es.mdh.se/pdf_publications/948.pdf *) - let bit2 f ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) - else top () - - let logor ik x y = bit2 Z.logor ik x y - - let logand ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then - (* both arguments constant *) - Some (Z.logand c c', Z.zero) - else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then - (* x & 1 and x == c (mod 2*z) *) - (* Value is equal to LSB of c *) - Some (Z.logand c c', Z.zero) - else - top () - - let logxor ik x y = bit2 Z.logxor ik x y - - let rem ik x y = - match x, y with - | None, None -> bot() - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some(c2, m2) -> - if m2 =: Z.zero then - if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then - Some (c1 %: c2, Z.zero) - else - normalize ik (Some (c1, (Z.gcd m1 c2))) - else - normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) - - let rem ik x y = let res = rem ik x y in - if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; - res - - let div ?(no_ov=false) ik x y = - match x,y with - | None, None -> bot () - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, x when leq zero x -> top () - | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () - | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) - | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) - | _, _ -> top () - - - let div ?no_ov ik x y = - let res = div ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty - res ; - res - - let ne ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) - | x, y -> if meet ik x y = None then of_bool ik true else top_bool - - let eq ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) - | x, y -> if meet ik x y <> None then top_bool else of_bool ik false - - let comparison ik op x y = match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) -> - if m1 =: Z.zero && m2 =: Z.zero then - if op c1 c2 then of_bool ik true else of_bool ik false - else - top_bool - - let ge ik x y = comparison ik (>=:) x y - - let ge ik x y = - let res = ge ik x y in - if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let le ik x y = comparison ik (<=:) x y - - let le ik x y = - let res = le ik x y in - if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let gt ik x y = comparison ik (>:) x y - - - let gt ik x y = - let res = gt ik x y in - if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; - res - - let lt ik x y = comparison ik (<:) x y - - let lt ik x y = - let res = lt ik x y in - if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; - res - - let invariant_ikind e ik x = - match x with - | x when is_top x -> Invariant.top () - | Some (c, m) when m =: Z.zero -> - IntInvariant.of_int e ik c - | Some (c, m) -> - let open Cil in - let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in - Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) - | None -> Invariant.none - - let arbitrary ik = - let open QCheck in - let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in - let cong_arb = pair int_arb int_arb in - let of_pair ik p = normalize ik (Some p) in - let to_pair = Option.get in - set_print show (map ~rev:to_pair (of_pair ik) cong_arb) - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =: Z.zero then - if c <: x || c >: y then None else Some (c, Z.zero) - else - let rcx = x +: ((c -: x) %: Z.abs m) in - let lcy = y -: ((y -: c) %: Z.abs m) in - if rcx >: lcy then None - else if rcx =: lcy then Some (rcx, Z.zero) - else cong - | _ -> None - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = - let pretty_intv _ i = - match i with - | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u - | _ -> Pretty.text ("Display Error") in - let refn = refine_with_interval ik cong intv in - if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; - refn - - let refine_with_congruence ik a b = meet ik a b - let refine_with_excl_list ik a b = a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct - - include D - - let lift v = (v, {overflow=false; underflow=false}) - - let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = lift @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = lift @@ D.shift_left ik x y - - let shift_right ik x y = lift @@ D.shift_right ik x y - -end - - - - - - -(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) -(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) -module IntDomTupleImpl = struct - include Printable.Std (* for default invariant, tag, ... *) - - open Batteries - type int_t = Z.t - module I1 = SOverflowLifter (DefExc) - module I2 = Interval - module I3 = SOverflowLifter (Enums) - module I4 = SOverflowLifter (Congruence) - module I5 = IntervalSetFunctor (IntOps.BigIntOps) - module I6 = BitfieldFunctor (IntOps.BigIntOps) - - type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option - [@@deriving eq, ord, hash] - - let name () = "intdomtuple" - - (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) - let no_interval = Tuple6.map2 (const None) - let no_intervalSet = Tuple6.map5 (const None) - - type 'a m = (module SOverflow with type t = 'a) - type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) - - (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) - type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) - type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) - type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) - - type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) - type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) - type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] - type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] - type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] - type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) - let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) - let create r x = (* use where values are introduced *) - create r x (int_precision_from_node_or_config ()) - let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) - let create2 r x = (* use where values are introduced *) - create2 r x (int_precision_from_node_or_config ()) - - let no_overflow ik = function - | Some(_, {underflow; overflow}) -> not (underflow || overflow) - | _ -> false - - let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = - let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in - if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( - let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in - let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in - let underflow = underflow_intv && underflow_intv_set in - let overflow = overflow_intv && overflow_intv_set in - set_overflow_flag ~cast ~underflow ~overflow ik; - ); - no_ov - - let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = - let f b g = if b then Some (g x) else None in - let map x = Option.map fst x in - let intv = f p2 @@ r.fi2_ovc (module I2) in - let intv_set = f p5 @@ r.fi2_ovc (module I5) in - ignore (check_ov ~cast:false ik intv intv_set); - map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) - - let create2_ovc ik r x = (* use where values are introduced *) - create2_ovc ik r x (int_precision_from_node_or_config ()) - - - let opt_map2 f ?no_ov = - curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None - - let to_list x = Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) - let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) - - let exists = function - | (Some true, _, _, _, _,_) - | (_, Some true, _, _, _,_) - | (_, _, Some true, _, _,_) - | (_, _, _, Some true, _,_) - | (_, _, _, _, Some true,_) - | (_, _, _, _, _, Some true) - -> true - | _ -> - false - - let for_all = function - | (Some false, _, _, _, _,_) - | (_, Some false, _, _, _,_) - | (_, _, Some false, _, _,_) - | (_, _, _, Some false, _,_) - | (_, _, _, _, Some false,_) - | (_, _, _, _, _, Some false) - -> - false - | _ -> - true - - (* f0: constructors *) - let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () - let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () - let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } - let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } - let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } - let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} - let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } - let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } - let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } - let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } - let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } - - let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_congruence ik a cong - , opt I2.refine_with_congruence ik b cong - , opt I3.refine_with_congruence ik c cong - , opt I4.refine_with_congruence ik d cong - , opt I5.refine_with_congruence ik e cong - , opt I6.refine_with_congruence ik f cong - ) - - let refine_with_interval ik (a, b, c, d, e,f) intv = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_interval ik a intv - , opt I2.refine_with_interval ik b intv - , opt I3.refine_with_interval ik c intv - , opt I4.refine_with_interval ik d intv - , opt I5.refine_with_interval ik e intv - , opt I6.refine_with_interval ik f intv ) - - let refine_with_excl_list ik (a, b, c, d, e,f) excl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_excl_list ik a excl - , opt I2.refine_with_excl_list ik b excl - , opt I3.refine_with_excl_list ik c excl - , opt I4.refine_with_excl_list ik d excl - , opt I5.refine_with_excl_list ik e excl - , opt I6.refine_with_excl_list ik f excl ) - - let refine_with_incl_list ik (a, b, c, d, e,f) incl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_incl_list ik a incl - , opt I2.refine_with_incl_list ik b incl - , opt I3.refine_with_incl_list ik c incl - , opt I4.refine_with_incl_list ik d incl - , opt I5.refine_with_incl_list ik e incl - , opt I6.refine_with_incl_list ik f incl ) - - - let mapp r (a, b, c, d, e, f) = - let map = BatOption.map in - ( map (r.fp (module I1)) a - , map (r.fp (module I2)) b - , map (r.fp (module I3)) c - , map (r.fp (module I4)) d - , map (r.fp (module I5)) e - , map (r.fp (module I6)) f) - - - let mapp2 r (a, b, c, d, e, f) = - BatOption. - ( map (r.fp2 (module I1)) a - , map (r.fp2 (module I2)) b - , map (r.fp2 (module I3)) c - , map (r.fp2 (module I4)) d - , map (r.fp2 (module I5)) e - , map (r.fp2 (module I6)) f) - - - (* exists/for_all *) - let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } - let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } - let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } - let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } - - let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - ( opt_map2 (r.f2p (module I1)) xa ya - , opt_map2 (r.f2p (module I2)) xb yb - , opt_map2 (r.f2p (module I3)) xc yc - , opt_map2 (r.f2p (module I4)) xd yd - , opt_map2 (r.f2p (module I5)) xe ye - , opt_map2 (r.f2p (module I6)) xf yf) - - (* f2p: binary projections *) - let (%%) f g x = f % (g x) (* composition for binary function g *) - - let leq = - for_all - %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} - - let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) - - let to_excl_list x = - let merge ps = - let (vs, rs) = List.split ps in - let (mins, maxs) = List.split rs in - (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge - - let to_incl_list x = - let hd l = match l with h::t -> h | _ -> [] in - let tl l = match l with h::t -> t | _ -> [] in - let a y = BatSet.of_list (hd y) in - let b y = BatList.map BatSet.of_list (tl y) in - let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge - - let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in - if n = 1 then Some (List.hd xs) - else ( - if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) - None - ) - let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } - - let pretty () x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) - | _ -> - mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x - |> to_list - |> (fun xs -> - text "(" ++ ( - try - List.reduce (fun a b -> a ++ text "," ++ b) xs - with Invalid_argument _ -> - nil) - ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) - - let refine_functions ik : (t -> t) list = - let maybe reffun ik domtup dom = - match dom with Some y -> reffun ik domtup y | _ -> domtup - in - [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e,f) b); (* TODO: get interval across all domains with minimal and maximal *) - (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e,f) d)] - - let refine ik ((a, b, c, d, e,f) : t ) : t = - let dt = ref (a, b, c, d, e,f) in - (match get_refinement () with - | "never" -> () - | "once" -> - List.iter (fun f -> dt := f !dt) (refine_functions ik); - | "fixpoint" -> - let quit_loop = ref false in - while not !quit_loop do - let old_dt = !dt in - List.iter (fun f -> dt := f !dt) (refine_functions ik); - quit_loop := equal old_dt !dt; - if is_bot !dt then dt := bot_of ik; quit_loop := true; - if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; - done; - | _ -> () - ); !dt - - - (* map with overflow check *) - let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = - let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in - let intv = map (r.f1_ovc (module I2)) b in - let intv_set = map (r.f1_ovc (module I5)) e in - let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a - , BatOption.map fst intv - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d - , BatOption.map fst intv_set - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) - - (* map2 with overflow check *) - let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in - let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in - let no_ov = check_ov ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya - , BatOption.map fst intv - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd - , BatOption.map fst intv_set - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) - - let map ik r (a, b, c, d, e, f) = - refine ik - BatOption. - ( map (r.f1 (module I1)) a - , map (r.f1 (module I2)) b - , map (r.f1 (module I3)) c - , map (r.f1 (module I4)) d - , map (r.f1 (module I5)) e - , map (r.f1 (module I6)) f) - - let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - let r = - ( opt_map2 (r.f2 (module I1)) xa ya - , opt_map2 (r.f2 (module I2)) xb yb - , opt_map2 (r.f2 (module I3)) xc yc - , opt_map2 (r.f2 (module I4)) xd yd - , opt_map2 (r.f2 (module I5)) xe ye - , opt_map2 (r.f2 (module I6)) xf yf) - in - if norefine then r else refine ik r - - - (* f1: unary ops *) - let neg ?no_ov ik = - mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} - - let lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} - - let c_lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = - mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} - - (* fp: projections *) - let equal_to i x = - let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple6.enum |> List.of_enum |> List.filter_map identity in - if List.mem `Eq xs then `Eq else - if List.mem `Neq xs then `Neq else - `Top - - let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } - let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } - let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } - (* others *) - let show x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v - | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x - |> to_list - |> String.concat "; " - let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } - - (* `map/opt_map` are used by `project` *) - let opt_map b f = - curry @@ function None, true -> f | x, y when y || b -> x | _ -> None - let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = - ( opt_map keep (r.f3 (module I1)) i1 b1 - , opt_map keep (r.f3 (module I2)) i2 b2 - , opt_map keep (r.f3 (module I3)) i3 b3 - , opt_map keep (r.f3 (module I4)) i4 b4 - , opt_map keep (r.f3 (module I5)) i5 b5 - , opt_map keep (r.f3 (module I6)) i6 b6) - - (** Project tuple t to precision p - * We have to deactivate IntDomains after the refinement, since we might - * lose information if we do it before. E.g. only "Interval" is active - * and shall be projected to only "Def_Exc". By seting "Interval" to None - * before refinement we have no information for "Def_Exc". - * - * Thus we have 3 Steps: - * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element - * 2. Refine the padded t - * 3. Set elements of t to `None` if p is false for this element - * - * Side Note: - * ~keep is used to reuse `map/opt_map` for Step 1 and 3. - * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. - * This way we won't loose any information for the refinement. - * ~keep:false will set the elements to `None` as defined by p *) - let project ik (p: int_precision) t = - let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in - let t_refined = refine ik t_padded in - map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p - - - (* f2: binary ops *) - let join ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} - - let meet ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} - - let widen ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} - - let narrow ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} - - let add ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} - - let sub ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} - - let mul ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} - - let div ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} - - let rem ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} - - let lt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} - - let gt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} - - let le ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} - - let ge ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} - - let eq ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} - - let ne ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} - - let logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} - - let logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} - - let logxor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} - - let shift_left ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} - - let shift_right ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} - - let c_logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} - - let c_logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} - - - (* printing boilerplate *) - let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y - let printXml f x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) - | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) - - let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = - (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) - let simplify_int fallback = - match to_int x with - | Some v -> - (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) - IntInvariant.of_int e ik v - | None -> - fallback () - in - let simplify_all () = - match to_incl_list x with - | Some ps -> - (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) - IntInvariant.of_incl_list e ik ps - | None -> - (* Get interval bounds from all domains (intervals and exclusion set ranges). *) - let min = minimal x in - let max = maximal x in - let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) - (* "Refine" out-of-bounds exclusions for simpler output. *) - let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in - let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in - Invariant.( - IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) - IntInvariant.of_excl_list e ik ns && - Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) - Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) - ) - in - let simplify_none () = - let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in - List.fold_left (fun a i -> - Invariant.(a && i) - ) (Invariant.top ()) is - in - match GobConfig.get_string "ana.base.invariant.int.simplify" with - | "none" -> simplify_none () - | "int" -> simplify_int simplify_none - | "all" -> simplify_int simplify_all - | _ -> assert false - - let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) - - let relift (a, b, c, d, e, f) = - (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) -end - -module IntDomTuple = -struct - module I = IntDomLifter (IntDomTupleImpl) - include I - - let top () = failwith "top in IntDomTuple not supported. Use top_of instead." - let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} - - let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} -end - -let of_const (i, ik, str) = IntDomTuple.of_int ik i +open GobConfig +open GoblintCil +open Pretty +open PrecisionUtil + +module M = Messages + +let (%) = Batteries.(%) +let (|?) = Batteries.(|?) + +exception IncompatibleIKinds of string +exception Unknown +exception Error +exception ArithmeticOnIntegerBot of string + + + +(* Custom Tuple6 as Batteries only provides up to Tuple5 *) +module Tuple6 = struct + type ('a,'b,'c,'d,'e,'f) t = 'a * 'b * 'c * 'd * 'e * 'f + + type 'a enumerable = 'a * 'a * 'a * 'a * 'a * 'a + + let make a b c d e f= (a, b, c, d, e, f) + + let first (a,_,_,_,_, _) = a + let second (_,b,_,_,_, _) = b + let third (_,_,c,_,_, _) = c + let fourth (_,_,_,d,_, _) = d + let fifth (_,_,_,_,e, _) = e + let sixth (_,_,_,_,_, f) = f + + let map f1 f2 f3 f4 f5 f6 (a,b,c,d,e,f) = + let a = f1 a in + let b = f2 b in + let c = f3 c in + let d = f4 d in + let e = f5 e in + let f = f6 f in + (a, b, c, d, e, f) + + let mapn fn (a,b,c,d,e,f) = + let a = fn a in + let b = fn b in + let c = fn c in + let d = fn d in + let e = fn e in + let f = fn f in + (a, b, c, d, e, f) + + let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) + let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) + let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) + let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) + let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) + let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) + + + + + let curry fn a b c d e f= fn (a,b,c,d,e,f) + let uncurry fn (a,b,c,d,e,f) = fn a b c d e f + + let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) + + let of_enum e = match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some a -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some b -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some c -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some d -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some e -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some f -> (a,b,c,d,e,f) + + let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e print_f out (a,b,c,d,e,f) = + BatIO.nwrite out first; + print_a out a; + BatIO.nwrite out sep; + print_b out b; + BatIO.nwrite out sep; + print_c out c; + BatIO.nwrite out sep; + print_d out d; + BatIO.nwrite out sep; + print_e out e; + BatIO.nwrite out sep; + print_f out f + BatIO.nwrite out last + + + let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = + print ~first ~sep ~last printer printer printer printer printer out pair + + let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) ?(cmp6=Pervasives.compare) (a1,a2,a3,a4,a5,a6) (b1,b2,b3,b4,b5,b6) = + let c1 = cmp1 a1 b1 in + if c1 <> 0 then c1 else + let c2 = cmp2 a2 b2 in + if c2 <> 0 then c2 else + let c3 = cmp3 a3 b3 in + if c3 <> 0 then c3 else + let c4 = cmp4 a4 b4 in + if c4 <> 0 then c4 else + let c5 = cmp5 a5 b5 in + if c5 <> 0 then c5 else + cmp5 a6 b6 + + open BatOrd + let eq eq1 eq2 eq3 eq4 eq5 eq6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + bin_eq eq1 t1 t1' + (bin_eq eq2 t2 t2' + (bin_eq eq3 t3 t3' + (bin_eq eq4 t4 t4' + (bin_eq eq5 t5 t5' eq6)))) t6 t6' + + let ord ord1 ord2 ord3 ord4 ord5 ord6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + bin_ord ord1 t1 t1' + (bin_ord ord2 t2 t2' + (bin_ord ord3 t3 t3' + (bin_ord ord4 t4 t4' + (bin_ord ord5 t5 t5' ord6)))) t6 t6' + + let comp comp1 comp2 comp3 comp4 comp5 comp6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + let c1 = comp1 t1 t1' in + if c1 <> 0 then c1 else + let c2 = comp2 t2 t2' in + if c2 <> 0 then c2 else + let c3 = comp3 t3 t3' in + if c3 <> 0 then c3 else + let c4 = comp4 t4 t4' in + if c4 <> 0 then c4 else + let c5 = comp5 t5 t5' in + if c5 <> 0 then c5 else + comp6 t6 t6' + + module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let eq = eq A.eq B.eq C.eq D.eq E.eq F.eq + end + + module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord ) (F : Ord) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let ord = ord A.ord B.ord C.ord D.ord E.ord F.ord + end + + module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp ) (F : Comp) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let compare = comp A.compare B.compare C.compare D.compare E.compare F.compare + end +end + + + +(** Define records that hold mutable variables representing different Configuration values. + * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) +type ana_int_config_values = { + mutable interval_threshold_widening : bool option; + mutable interval_narrow_by_meet : bool option; + mutable def_exc_widen_by_join : bool option; + mutable interval_threshold_widening_constants : string option; + mutable refinement : string option; +} + +let ana_int_config: ana_int_config_values = { + interval_threshold_widening = None; + interval_narrow_by_meet = None; + def_exc_widen_by_join = None; + interval_threshold_widening_constants = None; + refinement = None; +} + +let get_interval_threshold_widening () = + if ana_int_config.interval_threshold_widening = None then + ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); + Option.get ana_int_config.interval_threshold_widening + +let get_interval_narrow_by_meet () = + if ana_int_config.interval_narrow_by_meet = None then + ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); + Option.get ana_int_config.interval_narrow_by_meet + +let get_def_exc_widen_by_join () = + if ana_int_config.def_exc_widen_by_join = None then + ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); + Option.get ana_int_config.def_exc_widen_by_join + +let get_interval_threshold_widening_constants () = + if ana_int_config.interval_threshold_widening_constants = None then + ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); + Option.get ana_int_config.interval_threshold_widening_constants + +let get_refinement () = + if ana_int_config.refinement = None then + ana_int_config.refinement <- Some (get_string "ana.int.refinement"); + Option.get ana_int_config.refinement + + + +(** Whether for a given ikind, we should compute with wrap-around arithmetic. + * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) +let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" + +(** Whether for a given ikind, we should assume there are no overflows. + * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) +let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" + +let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds +let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) + +type overflow_info = { overflow: bool; underflow: bool;} + +let set_overflow_flag ~cast ~underflow ~overflow ik = + if !AnalysisState.executing_speculative_computations then + (* Do not produce warnings when the operations are not actually happening in code *) + () + else + let signed = Cil.isSigned ik in + if !AnalysisState.postsolving && signed && not cast then + AnalysisState.svcomp_may_overflow := true; + let sign = if signed then "Signed" else "Unsigned" in + match underflow, overflow with + | true, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign + | true, false -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign + | false, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign + | false, false -> assert false + +let reset_lazy () = + ResettableLazy.reset widening_thresholds; + ResettableLazy.reset widening_thresholds_desc; + ana_int_config.interval_threshold_widening <- None; + ana_int_config.interval_narrow_by_meet <- None; + ana_int_config.def_exc_widen_by_join <- None; + ana_int_config.interval_threshold_widening_constants <- None; + ana_int_config.refinement <- None + +module type Arith = +sig + type t + val neg: t -> t + val add: t -> t -> t + val sub: t -> t -> t + val mul: t -> t -> t + val div: t -> t -> t + val rem: t -> t -> t + + val lt: t -> t -> t + val gt: t -> t -> t + val le: t -> t -> t + val ge: t -> t -> t + val eq: t -> t -> t + val ne: t -> t -> t + + val lognot: t -> t + val logand: t -> t -> t + val logor : t -> t -> t + val logxor: t -> t -> t + + val shift_left : t -> t -> t + val shift_right: t -> t -> t + + val c_lognot: t -> t + val c_logand: t -> t -> t + val c_logor : t -> t -> t + +end + +module type ArithIkind = +sig + type t + val neg: Cil.ikind -> t -> t + val add: Cil.ikind -> t -> t -> t + val sub: Cil.ikind -> t -> t -> t + val mul: Cil.ikind -> t -> t -> t + val div: Cil.ikind -> t -> t -> t + val rem: Cil.ikind -> t -> t -> t + + val lt: Cil.ikind -> t -> t -> t + val gt: Cil.ikind -> t -> t -> t + val le: Cil.ikind -> t -> t -> t + val ge: Cil.ikind -> t -> t -> t + val eq: Cil.ikind -> t -> t -> t + val ne: Cil.ikind -> t -> t -> t + + val lognot: Cil.ikind -> t -> t + val logand: Cil.ikind -> t -> t -> t + val logor : Cil.ikind -> t -> t -> t + val logxor: Cil.ikind -> t -> t -> t + + val shift_left : Cil.ikind -> t -> t -> t + val shift_right: Cil.ikind -> t -> t -> t + + val c_lognot: Cil.ikind -> t -> t + val c_logand: Cil.ikind -> t -> t -> t + val c_logor : Cil.ikind -> t -> t -> t + +end + +(* Shared functions between S and Z *) +module type B = +sig + include Lattice.S + type int_t + val bot_of: Cil.ikind -> t + val top_of: Cil.ikind -> t + val to_int: t -> int_t option + val equal_to: int_t -> t -> [`Eq | `Neq | `Top] + + val to_bool: t -> bool option + val to_excl_list: t -> (int_t list * (int64 * int64)) option + val of_excl_list: Cil.ikind -> int_t list -> t + val is_excl_list: t -> bool + + val to_incl_list: t -> int_t list option + + val maximal : t -> int_t option + val minimal : t -> int_t option + + val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t +end + +(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) +module type IkindUnawareS = +sig + include B + include Arith with type t := t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: int_t -> t + val of_bool: bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val arbitrary: unit -> t QCheck.arbitrary + val invariant: Cil.exp -> t -> Invariant.t +end + +(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) +module type S = +sig + include B + include ArithIkind with type t:= t + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val neg : ?no_ov:bool -> Cil.ikind -> t -> t + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t + + val join: Cil.ikind -> t -> t -> t + val meet: Cil.ikind -> t -> t -> t + val narrow: Cil.ikind -> t -> t -> t + val widen: Cil.ikind -> t -> t -> t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val is_top_of: Cil.ikind -> t -> bool + val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t + + val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t + val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t + + val project: Cil.ikind -> int_precision -> t -> t + val arbitrary: Cil.ikind -> t QCheck.arbitrary +end + +module type SOverflow = +sig + + include S + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val of_int : Cil.ikind -> int_t -> t * overflow_info + + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + + val shift_left : Cil.ikind -> t -> t -> t * overflow_info + + val shift_right : Cil.ikind -> t -> t -> t * overflow_info +end + +module type Y = +sig + (* include B *) + include B + include Arith with type t:= t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val is_top_of: Cil.ikind -> t -> bool + + val project: int_precision -> t -> t + val invariant: Cil.exp -> t -> Invariant.t +end + +module type Z = Y with type int_t = Z.t + + +module IntDomLifter (I : S) = +struct + open Cil + type int_t = I.int_t + type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] + + let ikind {ikind; _} = ikind + + (* Helper functions *) + let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) + let lift op x = {x with v = op x.ikind x.v } + (* For logical operations the result is of type int *) + let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} + let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } + let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} + + let bot_of ikind = { v = I.bot_of ikind; ikind} + let bot () = failwith "bot () is not implemented for IntDomLifter." + let is_bot x = I.is_bot x.v + let top_of ikind = { v = I.top_of ikind; ikind} + let top () = failwith "top () is not implemented for IntDomLifter." + let is_top x = I.is_top x.v + + (* Leq does not check for ikind, because it is used in invariant with arguments of different type. + TODO: check ikinds here and fix invariant to work with right ikinds *) + let leq x y = I.leq x.v y.v + let join = lift2 I.join + let meet = lift2 I.meet + let widen = lift2 I.widen + let narrow = lift2 I.narrow + + let show x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + "⊤" + else + I.show x.v (* TODO add ikind to output *) + let pretty () x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + Pretty.text "⊤" + else + I.pretty () x.v (* TODO add ikind to output *) + let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) + let printXml o x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + BatPrintf.fprintf o "\n\n⊤\n\n\n" + else + I.printXml o x.v (* TODO add ikind to output *) + (* This is for debugging *) + let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" + let to_yojson x = I.to_yojson x.v + let invariant e x = + let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in + I.invariant_ikind e' x.ikind x.v + let tag x = I.tag x.v + let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." + let to_int x = I.to_int x.v + let of_int ikind x = { v = I.of_int ikind x; ikind} + let equal_to i x = I.equal_to i x.v + let to_bool x = I.to_bool x.v + let of_bool ikind b = { v = I.of_bool ikind b; ikind} + let to_excl_list x = I.to_excl_list x.v + let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} + let is_excl_list x = I.is_excl_list x.v + let to_incl_list x = I.to_incl_list x.v + let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} + let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} + let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} + let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} + let maximal x = I.maximal x.v + let minimal x = I.minimal x.v + + let neg = lift I.neg + let add = lift2 I.add + let sub = lift2 I.sub + let mul = lift2 I.mul + let div = lift2 I.div + let rem = lift2 I.rem + let lt = lift2_cmp I.lt + let gt = lift2_cmp I.gt + let le = lift2_cmp I.le + let ge = lift2_cmp I.ge + let eq = lift2_cmp I.eq + let ne = lift2_cmp I.ne + let lognot = lift I.lognot + let logand = lift2 I.logand + let logor = lift2 I.logor + let logxor = lift2 I.logxor + let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) + let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) + let c_lognot = lift_logical I.c_lognot + let c_logand = lift2 I.c_logand + let c_logor = lift2 I.c_logor + + let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} + + let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v + + let relift x = { v = I.relift x.v; ikind = x.ikind } + + let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } +end + +module type Ikind = +sig + val ikind: unit -> Cil.ikind +end + +module PtrDiffIkind : Ikind = +struct + let ikind = Cilfacade.ptrdiff_ikind +end + +module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = +struct + include I + let top () = I.top_of (Ik.ikind ()) + let bot () = I.bot_of (Ik.ikind ()) +end + +module Size = struct (* size in bits as int, range as int64 *) + open Cil + let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned + + let top_typ = TInt (ILongLong, []) + let min_for x = intKindForValue x (sign x = `Unsigned) + let bit = function (* bits needed for representation *) + | IBool -> 1 + | ik -> bytesSizeOfInt ik * 8 + let is_int64_big_int x = Z.fits_int64 x + let card ik = (* cardinality *) + let b = bit ik in + Z.shift_left Z.one b + let bits ik = (* highest bits for neg/pos values *) + let s = bit ik in + if isSigned ik then s-1, s-1 else 0, s + let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) + let range ik = + let a,b = bits ik in + let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in + let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) + x,y + + let is_cast_injective ~from_type ~to_type = + let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in + let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in + if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; + Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 + + let cast t x = (* TODO: overflow is implementation-dependent! *) + if t = IBool then + (* C11 6.3.1.2 Boolean type *) + if Z.equal x Z.zero then Z.zero else Z.one + else + let a,b = range t in + let c = card t in + let y = Z.erem x c in + let y = if Z.gt y b then Z.sub y c + else if Z.lt y a then Z.add y c + else y + in + if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); + y + + let min_range_sign_agnostic x = + let size ik = + let a,b = bits_i64 ik in + Int64.neg a,b + in + if sign x = `Signed then + size (min_for x) + else + let a, b = size (min_for x) in + if b <= 64L then + let upper_bound_less = Int64.sub b 1L in + let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in + if x <= max_one_less then + a, upper_bound_less + else + a,b + else + a, b + + (* From the number of bits used to represent a positive value, determines the maximal representable value *) + let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) + + (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) + let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) + +end + + +module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct + open B + (* these should be overwritten for better precision if possible: *) + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let starting ?(suppress_ovwarn=false) ik x = top_of ik + let ending ?(suppress_ovwarn=false) ik x = top_of ik + let maximal x = None + let minimal x = None +end + +module Std (B: sig + type t + val name: unit -> string + val top_of: Cil.ikind -> t + val bot_of: Cil.ikind -> t + val show: t -> string + val equal: t -> t -> bool + end) = struct + include Printable.StdLeaf + let name = B.name (* overwrite the one from Printable.Std *) + open B + let is_top x = failwith "is_top not implemented for IntDomain.Std" + let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind + This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) + let is_top_of ik x = B.equal x (top_of ik) + + (* all output is based on B.show *) + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) + let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y + + include StdTop (B) +end + +(* Textbook interval arithmetic, without any overflow handling etc. *) +module IntervalArith (Ints_t : IntOps.IntOps) = struct + let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) + let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) + + let mul (x1, x2) (y1, y2) = + let x1y1 = (Ints_t.mul x1 y1) in + let x1y2 = (Ints_t.mul x1 y2) in + let x2y1 = (Ints_t.mul x2 y1) in + let x2y2 = (Ints_t.mul x2 y2) in + (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) + + let shift_left (x1,x2) (y1,y2) = + let y1p = Ints_t.shift_left Ints_t.one y1 in + let y2p = Ints_t.shift_left Ints_t.one y2 in + mul (x1, x2) (y1p, y2p) + + let div (x1, x2) (y1, y2) = + let x1y1n = (Ints_t.div x1 y1) in + let x1y2n = (Ints_t.div x1 y2) in + let x2y1n = (Ints_t.div x2 y1) in + let x2y2n = (Ints_t.div x2 y2) in + let x1y1p = (Ints_t.div x1 y1) in + let x1y2p = (Ints_t.div x1 y2) in + let x2y1p = (Ints_t.div x2 y1) in + let x2y2p = (Ints_t.div x2 y2) in + (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) + + let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) + let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) + + let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) + + let one = (Ints_t.one, Ints_t.one) + let zero = (Ints_t.zero, Ints_t.zero) + let top_bool = (Ints_t.zero, Ints_t.one) + + let to_int (x1, x2) = + if Ints_t.equal x1 x2 then Some x1 else None + + let upper_threshold u max_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + let max_ik' = Ints_t.to_bigint max_ik in + let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in + BatOption.map_default Ints_t.of_bigint max_ik t + let lower_threshold l min_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + let min_ik' = Ints_t.to_bigint min_ik in + let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in + BatOption.map_default Ints_t.of_bigint min_ik t + let is_upper_threshold u = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + List.exists (Z.equal u) ts + let is_lower_threshold l = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + List.exists (Z.equal l) ts +end + +module IntInvariant = +struct + let of_int e ik x = + if get_bool "witness.invariant.exact" then + Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) + else + Invariant.none + + let of_incl_list e ik ps = + match ps with + | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> + assert (List.mem Z.zero ps); + assert (List.mem Z.one ps); + Invariant.none + | [_] when get_bool "witness.invariant.exact" -> + Invariant.none + | _ :: _ :: _ + | [_] | [] -> + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in + Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) (Invariant.bot ()) ps + + let of_interval_opt e ik = function + | (Some x1, Some x2) when Z.equal x1 x2 -> + of_int e ik x1 + | x1_opt, x2_opt -> + let (min_ik, max_ik) = Size.range ik in + let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in + let i1 = + match x1_opt, inexact_type_bounds with + | Some x1, false when Z.equal min_ik x1 -> Invariant.none + | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) + | None, _ -> Invariant.none + in + let i2 = + match x2_opt, inexact_type_bounds with + | Some x2, false when Z.equal x2 max_ik -> Invariant.none + | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) + | None, _ -> Invariant.none + in + Invariant.(i1 && i2) + + let of_interval e ik (x1, x2) = + of_interval_opt e ik (Some x1, Some x2) + + let of_excl_list e ik ns = + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in + Invariant.(a && i) + ) (Invariant.top ()) ns +end + +module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = +struct + let name () = "intervals" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] + module IArith = IntervalArith (Ints_t) + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + let top_of ik = Some (range ik) + let bot () = None + let bot_of ik = bot () (* TODO: improve *) + + let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) -> + if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> + if Ints_t.compare x y > 0 then + (None,{underflow=false; overflow=false}) + else ( + let (min_ik, max_ik) = range ik in + let underflow = Ints_t.compare min_ik x > 0 in + let overflow = Ints_t.compare max_ik y < 0 in + let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in + let v = + if underflow || overflow then + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in + let resdiff = Ints_t.abs (Ints_t.sub y x) in + if Ints_t.compare resdiff diff > 0 then + top_of ik + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if Ints_t.compare l u <= 0 then + Some (l, u) + else + (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) + top_of ik + else if not cast && should_ignore_overflow ik then + let tl, tu = BatOption.get @@ top_of ik in + Some (Ints_t.max tl x, Ints_t.min tu y) + else + top_of ik + else + Some (x,y) + in + (v, ov_info) + ) + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst + + let meet ik (x:t) y = + match x, y with + | None, z | z, None -> None + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst + + (* TODO: change to_int signature so it returns a big_int *) + let to_int x = Option.bind x (IArith.to_int) + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) + let of_int ik (x: int_t) = of_interval ik (x,x) + let zero = Some IArith.zero + let one = Some IArith.one + let top_bool = Some IArith.top_bool + + let of_bool _ik = function true -> one | false -> zero + let to_bool (a: t) = match a with + | None -> None + | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) + + (* TODO: change signature of maximal, minimal to return big_int*) + let maximal = function None -> None | Some (x,y) -> Some y + let minimal = function None -> None | Some (x,y) -> Some x + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) + + let widen ik x y = + match x, y with + | None, z | z, None -> z + | Some (l0,u0), Some (l1,u1) -> + let (min_ik, max_ik) = range ik in + let threshold = get_interval_threshold_widening () in + let l2 = + if Ints_t.compare l0 l1 = 0 then l0 + else if threshold then IArith.lower_threshold l1 min_ik + else min_ik + in + let u2 = + if Ints_t.compare u0 u1 = 0 then u0 + else if threshold then IArith.upper_threshold u1 max_ik + else max_ik + in + norm ik @@ Some (l2,u2) |> fst + let widen ik x y = + let r = widen ik x y in + if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; + assert (leq x y); (* TODO: remove for performance reasons? *) + r + + let narrow ik x y = + match x, y with + | _,None | None, _ -> None + | Some (x1,x2), Some (y1,y2) -> + let threshold = get_interval_threshold_widening () in + let (min_ik, max_ik) = range ik in + let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in + let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in + norm ik @@ Some (lr,ur) |> fst + + + let narrow ik x y = + if get_interval_narrow_by_meet () then + meet ik x y + else + narrow ik x y + + let log f ~annihilator ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) ~annihilator:true + let c_logand = log (&&) ~annihilator:false + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let bit f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + let bitcomp f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let logxor = bit (fun _ik -> Ints_t.logxor) + + let logand ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) + | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst + | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst + | _ -> top_of ik + + let logor = bit (fun _ik -> Ints_t.logor) + + let bit1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_int i1 with + | Some x -> of_int ik (f ik x) |> fst + | _ -> top_of ik + + let lognot = bit1 (fun _ik -> Ints_t.lognot) + let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) + + let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) + + let binary_op_with_norm ?no_ov op ik x y = match x, y with + | None, None -> (None, {overflow=false; underflow= false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some x, Some y -> norm ik @@ Some (op x y) + + let add ?no_ov = binary_op_with_norm IArith.add + let mul ?no_ov = binary_op_with_norm IArith.mul + let sub ?no_ov = binary_op_with_norm IArith.sub + + let shift_left ik a b = + match is_bot a, is_bot b with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) + | _ -> + match a, minimal b, maximal b with + | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> + (try + let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in + norm ik @@ Some r + with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let rem ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (xl, xu), Some (yl, yu) -> + if is_top_of ik x && is_top_of ik y then + (* This is needed to preserve soundness also on things bigger than int32 e.g. *) + (* x: 3803957176L -> T in Interval32 *) + (* y: 4209861404L -> T in Interval32 *) + (* x % y: 3803957176L -> T in Interval32 *) + (* T in Interval32 is [-2147483648,2147483647] *) + (* the code below computes [-2147483647,2147483647] for this though which is unsound *) + top_of ik + else + (* If we have definite values, Ints_t.rem will give a definite result. + * Otherwise we meet with a [range] the result can be in. + * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. + * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) + let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in + let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in + let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range + + let rec div ?no_ov ik x y = + match x, y with + | None, None -> (bot (),{underflow=false; overflow=false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | (Some (x1,x2) as x), (Some (y1,y2) as y) -> + begin + let is_zero v = Ints_t.compare v Ints_t.zero = 0 in + match y1, y2 with + | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) + | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) + | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) + | _ -> binary_op_with_norm IArith.div ik x y + end + + let ne ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik true + else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then + of_bool ik false + else top_bool + + let eq ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then + of_bool ik true + else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik false + else top_bool + + let ge ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 then of_bool ik true + else if Ints_t.compare x2 y1 < 0 then of_bool ik false + else top_bool + + let le ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 <= 0 then of_bool ik true + else if Ints_t.compare y2 x1 < 0 then of_bool ik false + else top_bool + + let gt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 then of_bool ik true + else if Ints_t.compare x2 y1 <= 0 then of_bool ik false + else top_bool + + let lt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 < 0 then of_bool ik true + else if Ints_t.compare y2 x1 <= 0 then of_bool ik false + else top_bool + + let invariant_ikind e ik = function + | Some (x1, x2) -> + let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in + IntInvariant.of_interval e ik (x1', x2') + | None -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink = function + | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | None -> empty + in + QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) + + let modulo n k = + let result = Ints_t.rem n k in + if Ints_t.compare result Ints_t.zero >= 0 then result + else Ints_t.add result k + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None + else if Ints_t.equal m Ints_t.zero then + Some (c, c) + else + let (min_ik, max_ik) = range ik in + let rcx = + if Ints_t.equal x min_ik then x else + Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in + let lcy = + if Ints_t.equal y max_ik then y else + Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in + if Ints_t.compare rcx lcy > 0 then None + else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst + else norm ik @@ Some (rcx, lcy) |> fst + | _ -> None + + let refine_with_congruence ik x y = + let refn = refine_with_congruence ik x y in + if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; + refn + + let refine_with_interval ik a b = meet ik a b + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + match intv, excl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls, (rl, rh)) -> + let rec shrink op b = + let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in + if not (Ints_t.equal b new_b) then shrink op new_b else new_b + in + let (min_ik, max_ik) = range ik in + let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in + let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in + let intv' = norm ik @@ Some (l', u') |> fst in + let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in + meet ik intv' range + + let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = + match intv, incl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls) -> + let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in + let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in + match min None ls, max None ls with + | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) + | _, _-> intv + + let project ik p t = t +end + +module BitFieldArith (Ints_t : IntOps.IntOps) = struct + let zero_mask = Ints_t.zero + let one_mask = Ints_t.lognot zero_mask + + let of_int x = (Ints_t.lognot x, x) + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + + let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + + let is_constant (z,o) = (Ints_t.logxor z o) = one_mask + + let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) + + let nabla x y= if x = Ints_t.logor x y then x else one_mask + + let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) + + let lognot (z,o) = (o,z) + + let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), + Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) + + let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) + + let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) + + let min ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + let max ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + + if isSigned ik then + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero + +end + +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct + let name () = "bitfield" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] + + module BArith = BitFieldArith (Ints_t) + + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = top () + let bot_of ik = bot () + + let range ik bf = (BArith.min ik bf, BArith.max ik bf) + + let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) + + let norm ?(suppress_ovwarn=false) ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + + let (min,max) = range ik (z,o) in + let underflow = Z.compare min min_ik < 0 in + let overflow = Z.compare max max_ik > 0 in + + let new_bitfield= + (if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo)) + in + if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) + else (new_bitfield, {underflow=underflow; overflow=overflow}) + + let show t = + if t = bot () then "bot" else + if t = top () then "top" else + let (z,o) = t in + if BArith.is_constant t then + Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) + else + Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst + + let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst + + let leq (x:t) (y:t) = (BArith.join x y) = y + + let widen ik x y = (norm ik @@ BArith.widen x y) |> fst + let narrow ik x y = y + + let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) + + let to_int (z,o) = if is_bot (z,o) then None else + if BArith.is_constant (z,o) then Some o + else None + + let equal_to i bf = + if BArith.of_int i = bf then `Eq + else if leq (BArith.of_int i) bf then `Top + else `Neq + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + (* naive implentation -> horrible O(n) runtime *) + let (min_ik, max_ik) = Size.range ik in + let result = ref (bot ()) in + let current = ref (min_ik) in + let bf = ref (bot ()) in + while Z.leq !current max_ik do + bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); + current := Z.add !current Z.one + done; + norm ~suppress_ovwarn ik !result + + let of_bool _ik = function true -> BArith.one | false -> BArith.zero + + let to_bool d = + if not (leq BArith.zero d) then Some true + else if BArith.eq d BArith.zero then Some false + else None + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t + + + (* Logic *) + + let log1 f ik i1 = match to_bool i1 with + | None -> top_of ik + | Some x -> of_bool ik (f x) + + let log2 f ik i1 i2 = match (to_bool i1, to_bool i2) with + | None, None -> top_of ik + | None, Some x | Some x, None -> of_bool ik x + | Some x, Some y -> of_bool ik (f x y) + let c_logor ik i1 i2 = log2 (||) ik i1 i2 + + let c_logand ik i1 i2 = log2 (&&) ik i1 i2 + + let c_lognot ik i1 = log1 not ik i1 + + + (* Bitwise *) + + let logxor ik i1 i2 = BArith.logxor i1 i2 + + let logand ik i1 i2 = BArith.logand i1 i2 + + let logor ik i1 i2 = BArith.logor i1 i2 + + let lognot ik i1 = BArith.lognot i1 + + let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) + + let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) + + + (* Arith *) + + (* + add, sub and mul based on the paper + "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" + of Vishwanathan et al. + *) + + let add ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let sv = Ints_t.add pv qv in + let sm = Ints_t.add pm qm in + let sigma = Ints_t.add sv sm in + let chi = Ints_t.logxor sigma sv in + let mu = Ints_t.logor (Ints_t.logor pm qm) chi in + let rv = Ints_t.logand sv (Ints_t.lognot mu) in + let rm = mu in + let o3 = Ints_t.logor rv rm in + let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + ((z3, o3),{underflow=false; overflow=false}) + + let sub ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let dv = Ints_t.sub pv qv in + let alpha = Ints_t.add dv pm in + let beta = Ints_t.sub dv qm in + let chi = Ints_t.logxor alpha beta in + let mu = Ints_t.logor (Ints_t.logor pm qm) chi in + let rv = Ints_t.logand dv (Ints_t.lognot mu) in + let rm = mu in + let o3 = Ints_t.logor rv rm in + let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + ((z3, o3),{underflow=false; overflow=false}) + + let neg ?no_ov ik x = + M.trace "bitfield" "neg"; + sub ?no_ov ik BArith.zero x + + let mul ?no_ov ik (z1, o1) (z2, o2) = + let z1 = ref z1 in + let o1 = ref o1 in + let z2 = ref z2 in + let o2 = ref o2 in + let z3 = ref BArith.one_mask in + let o3 = ref BArith.zero_mask in + for i = Size.bit ik downto 0 do + if Ints_t.logand !o1 Ints_t.one == Ints_t.one then + if Ints_t.logand !z1 Ints_t.one == Ints_t.one then + let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in + z3 := Ints_t.logor !z3 tmp; + o3 := Ints_t.logor !o3 tmp + else + let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in + z3 := fst tmp; + o3 := snd tmp + ; + z1 := Ints_t.shift_right !z1 1; + o1 := Ints_t.shift_right !o1 1; + z2 := Ints_t.shift_left !z2 1; + o2 := Ints_t.shift_left !o2 1; + done; + ((!z3, !o3),{underflow=false; overflow=false}) + + let rec div ?no_ov ik (z1, o1) (z2, o2) = + if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) + else (top_of ik,{underflow=false; overflow=false}) + + let rem ik x y = + M.trace "bitfield" "rem"; + if BArith.is_constant x && BArith.is_constant y then ( + (* x % y = x - (x / y) * y *) + let tmp = fst (div ik x y) in + let tmp = fst (mul ik tmp y) in + fst (sub ik x tmp)) + else top_of ik + + let eq ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) + else if not (leq x y || leq y x) then of_bool ik false + else BArith.top_bool + + let ne ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) + else if not (leq x y || leq y x) then of_bool ik true + else BArith.top_bool + + let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true + else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false + else BArith.top_bool + + let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false + else BArith.top_bool + + let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true + else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false + else BArith.top_bool + + let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false + else BArith.top_bool + + + let invariant_ikind e ik (z,o) = + let range = range ik (z,o) in + IntInvariant.of_interval e ik range + + let starting ?(suppress_ovwarn=false) ik n = + if Ints_t.compare n Ints_t.zero >= 0 then + (* sign bit can only be 0, as all numbers will be positive *) + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let zs = BArith.one_mask in + let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + (norm ~suppress_ovwarn ik @@ (zs,os)) + else + (norm ~suppress_ovwarn ik @@ (top ())) + + let ending ?(suppress_ovwarn=false) ik n = + if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then + (* sign bit can only be 1, as all numbers will be negative *) + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + let os = BArith.one_mask in + (norm ~suppress_ovwarn ik @@ (zs,os)) + else + (norm ~suppress_ovwarn ik @@ (top ())) + + let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in + match intv, cong with + | (z,o), Some (c, m) -> + if is_power_of_two m then + let congruenceMask = Ints_t.lognot m in + let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in + let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + (newz, newo) + else + top_of ik + | _ -> top_of ik + + let refine_with_interval ik t i = t + + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t + + let invariant_ikind e ik = + M.trace "bitfield" "invariant_ikind"; + failwith "Not implemented" + + let refine_with_congruence ik bf (cong : (int_t * int_t ) option) : t = + M.trace "bitfield" "refine_with_congruence"; + bf + + let refine_with_interval ik bf (intv : (int_t * int_t) option) : t = + M.trace "bitfield" "refine_with_interval"; + bf + + let refine_with_excl_list ik bf (excl : (int_t list * (int64 * int64)) option) : t = + M.trace "bitfield" "refine_with_excl_list"; + bf + + let refine_with_incl_list ik t (incl : (int_t list) option) : t = + (* loop over all included ints *) + let incl_list_masks = match incl with + | None -> t + | Some ls -> + List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls + in + BArith.meet t incl_list_masks + + let arbitrary ik = + let open QCheck.Iter in + let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb1 int_arb2 in + let shrink = function + | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) + in + QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) + + let project ik p t = t +end + + +(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) +module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = +struct + + module Interval = IntervalFunctor (Ints_t) + module IArith = IntervalArith (Ints_t) + + + let name () = "interval_sets" + + type int_t = Ints_t.t + + let (>.) a b = Ints_t.compare a b > 0 + let (=.) a b = Ints_t.compare a b = 0 + let (<.) a b = Ints_t.compare a b < 0 + let (>=.) a b = Ints_t.compare a b >= 0 + let (<=.) a b = Ints_t.compare a b <= 0 + let (+.) a b = Ints_t.add a b + let (-.) a b = Ints_t.sub a b + + (* + Each domain's element is guaranteed to be in canonical form. That is, each interval contained + inside the set does not overlap with each other and they are not adjacent. + *) + type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + + let top_of ik = [range ik] + + let bot () = [] + + let bot_of ik = bot () + + let show (x: t) = + let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in + List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" + + (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) + type event = Enter of Ints_t.t | Exit of Ints_t.t + + let unbox_event = function Enter x -> x | Exit x -> x + + let cmp_events x y = + (* Deliberately comparing ints first => Cannot be derived *) + let res = Ints_t.compare (unbox_event x) (unbox_event y) in + if res <> 0 then res + else + begin + match (x, y) with + | (Enter _, Exit _) -> -1 + | (Exit _, Enter _) -> 1 + | (_, _) -> 0 + end + + let interval_set_to_events (xs: t) = + List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs + + let two_interval_sets_to_events (xs: t) (ys: t) = + let xs = interval_set_to_events xs in + let ys = interval_set_to_events ys in + List.merge cmp_events xs ys + + (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap + This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) + let combined_event_list lattice_op (xs:event list) = + let l = match lattice_op with `Join -> 1 | `Meet -> 2 in + let aux (interval_count, acc) = function + | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) + | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) + in + List.fold_left aux (0, []) xs |> snd |> List.rev + + let rec events_to_intervals = function + | [] -> [] + | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) + | _ -> failwith "Invalid events list" + + let remove_empty_gaps (xs: t) = + let aux acc (l, r) = match acc with + | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' + | _ -> (l, r)::acc + in + List.fold_left aux [] xs |> List.rev + + let canonize (xs: t) = + interval_set_to_events xs |> + List.sort cmp_events |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let unop (x: t) op = match x with + | [] -> [] + | _ -> canonize @@ List.concat_map op x + + let binop (x: t) (y: t) op : t = match x, y with + | [], _ -> [] + | _, [] -> [] + | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) + + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let minimal = function + | [] -> None + | (x, _)::_ -> Some x + + let maximal = function + | [] -> None + | xs -> Some (BatList.last xs |> snd) + + let equal_to_interval i (a, b) = + if a =. b && b =. i then + `Eq + else if a <=. i && i <=. b then + `Top + else + `Neq + + let equal_to i xs = match List.map (equal_to_interval i) xs with + | [] -> failwith "unsupported: equal_to with bottom" + | [`Eq] -> `Eq + | ys when List.for_all ((=) `Neq) ys -> `Neq + | _ -> `Top + + let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = + if x >. y then + ([],{underflow=false; overflow=false}) + else + let (min_ik, max_ik) = range ik in + let underflow = min_ik >. x in + let overflow = max_ik <. y in + let v = if underflow || overflow then + begin + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (max_ik -. min_ik) in + let resdiff = Ints_t.abs (y -. x) in + if resdiff >. diff then + [range ik] + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if l <=. u then + [(l, u)] + else + (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) + [(min_ik, u); (l, max_ik)] + else if not cast && should_ignore_overflow ik then + [Ints_t.max min_ik x, Ints_t.min max_ik y] + else + [range ik] + end + else + [(x,y)] + in + if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) + + let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = + let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) + + let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> + let res = List.map op (BatList.cartesian_product x y) in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let unary_op_with_norm op (ik:ikind) (x: t) = match x with + | [] -> ([],{overflow=false; underflow=false}) + | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x + + let rec leq (xs: t) (ys: t) = + let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in + match xs, ys with + | [], _ -> true + | _, [] -> false + | (xl,xr)::xs', (yl,yr)::ys' -> + if leq_interval (xl,xr) (yl,yr) then + leq xs' ys + else if xr <. yl then + false + else + leq xs ys' + + let join ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let meet ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Meet |> + events_to_intervals + + let to_int = function + | [x] -> IArith.to_int x + | _ -> None + + let zero = [IArith.zero] + let one = [IArith.one] + let top_bool = [IArith.top_bool] + + let not_bool (x:t) = + let is_false x = equal x zero in + let is_true x = equal x one in + if is_true x then zero else if is_false x then one else top_bool + + let to_bool = function + | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false + | x -> if leq zero x then None else Some true + + let of_bool _ = function true -> one | false -> zero + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) + + let of_int ik (x: int_t) = of_interval ik (x, x) + + let lt ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <. min_y then + of_bool ik true + else if min_x >=. max_y then + of_bool ik false + else + top_bool + + let le ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <=. min_y then + of_bool ik true + else if min_x >. max_y then + of_bool ik false + else + top_bool + + let gt ik x y = not_bool @@ le ik x y + + let ge ik x y = not_bool @@ lt ik x y + + let eq ik x y = match x, y with + | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> + one + | _ -> + if is_bot (meet ik x y) then + zero + else + top_bool + + let ne ik x y = not_bool @@ eq ik x y + let interval_to_int i = Interval.to_int (Some i) + let interval_to_bool i = Interval.to_bool (Some i) + + let log f ik (i1, i2) = + match (interval_to_bool i1, interval_to_bool i2) with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + + let bit f ik (i1, i2) = + match (interval_to_int i1), (interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + + let bitcomp f ik (i1, i2) = + match (interval_to_int i1, interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) + | _, _ -> (top_of ik,{overflow=false; underflow=false}) + + let logand ik x y = + let interval_logand = bit Ints_t.logand ik in + binop x y interval_logand + + let logor ik x y = + let interval_logor = bit Ints_t.logor ik in + binop x y interval_logor + + let logxor ik x y = + let interval_logxor = bit Ints_t.logxor ik in + binop x y interval_logxor + + let lognot ik x = + let interval_lognot i = + match interval_to_int i with + | Some x -> of_int ik (Ints_t.lognot x) |> fst + | _ -> top_of ik + in + unop x interval_lognot + + let shift_left ik x y = + let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftleft + + let shift_right ik x y = + let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftright + + let c_lognot ik x = + let log1 f ik i1 = + match interval_to_bool i1 with + | Some x -> of_bool ik (f x) + | _ -> top_of ik + in + let interval_lognot = log1 not ik in + unop x interval_lognot + + let c_logand ik x y = + let interval_logand = log (&&) ik in + binop x y interval_logand + + let c_logor ik x y = + let interval_logor = log (||) ik in + binop x y interval_logor + + let add ?no_ov = binary_op_with_norm IArith.add + let sub ?no_ov = binary_op_with_norm IArith.sub + let mul ?no_ov = binary_op_with_norm IArith.mul + let neg ?no_ov = unary_op_with_norm IArith.neg + + let div ?no_ov ik x y = + let rec interval_div x (y1, y2) = begin + let top_of ik = top_of ik |> List.hd in + let is_zero v = v =. Ints_t.zero in + match y1, y2 with + | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) + | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) + | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik + | _ -> IArith.div x (y1, y2) + end + in binary_op_with_norm interval_div ik x y + + let rem ik x y = + let interval_rem (x, y) = + if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then + top_of ik + else + let (xl, xu) = x in let (yl, yu) = y in + let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in + let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in + let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit Ints_t.rem ik (x, y)) [range] + in + binop x y interval_rem + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x + + (* + narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys + *) + let narrow ik xs ys = match xs ,ys with + | [], _ -> [] | _ ,[] -> xs + | _, _ -> + let min_xs = minimal xs |> Option.get in + let max_xs = maximal xs |> Option.get in + let min_ys = minimal ys |> Option.get in + let max_ys = maximal ys |> Option.get in + let min_range,max_range = range ik in + let threshold = get_interval_threshold_widening () in + let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in + let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in + xs + |> (function (_, y)::z -> (min, y)::z | _ -> []) + |> List.rev + |> (function (x, _)::z -> (x, max)::z | _ -> []) + |> List.rev + + (* + 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. + and joins all intervals in xs assigned to the same interval in ys as one interval. + 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. + 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) + + The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. + *) + let widen ik xs ys = + let (min_ik,max_ik) = range ik in + let threshold = get_bool "ana.int.interval_threshold_widening" in + let upper_threshold (_,u) = IArith.upper_threshold u max_ik in + let lower_threshold (l,_) = IArith.lower_threshold l min_ik in + (*obtain partitioning of xs intervals according to the ys interval that includes them*) + let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= + match xs,ys with + | _, [] -> [] + | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys + | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) + | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys + in + let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in + (*merge a pair of adjacent partitions*) + let merge_pair ik (a,b) (c,d) = + let new_a = function + | None -> Some (upper_threshold b, upper_threshold b) + | Some (ax,ay) -> Some (ax, upper_threshold b) + in + let new_c = function + | None -> Some (lower_threshold d, lower_threshold d) + | Some (cx,cy) -> Some (lower_threshold d, cy) + in + if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then + [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] + else + [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] + in + let partitions_are_approaching part_left part_right = match part_left, part_right with + | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) + | _,_ -> false + in + (*merge all approaching pairs of adjacent partitions*) + let rec merge_list ik = function + | [] -> [] + | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) + | x::xs -> x :: merge_list ik xs + in + (*expands left extremity*) + let widen_left = function + | [] -> [] + | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts + | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts + | x -> x + in + (*expands right extremity*) + let widen_right x = + let map_rightmost = function + | [] -> [] + | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts + | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts + | x -> x + in + List.rev x |> map_rightmost |> List.rev + in + interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd + + let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) + + let invariant_ikind e ik xs = + List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> + let open Invariant in List.fold_left (||) (bot ()) + + let modulo n k = + let result = Ints_t.rem n k in + if result >=. Ints_t.zero then result + else result +. k + + let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = + let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =. Ints_t.zero && (c <. x || c >. y) then [] + else if m =. Ints_t.zero then + [(c, c)] + else + let (min_ik, max_ik) = range ik in + let rcx = + if x =. min_ik then x else + x +. (modulo (c -. x) (Ints_t.abs m)) in + let lcy = + if y =. max_ik then y else + y -. (modulo (y -. c) (Ints_t.abs m)) in + if rcx >. lcy then [] + else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst + else norm_interval ik (rcx, lcy) |> fst + | _ -> [] + in + List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs + + let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] + + let refine_with_incl_list ik intvs = function + | None -> intvs + | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) + + let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = + let intv1 = (min, excl -. Ints_t.one) in + let intv2 = (excl +. Ints_t.one, max) in + norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst + + let of_excl_list ik (excls: int_t list) = + let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in + let res = List.fold_left (meet ik) (top_of ik) excl_list in + res + + let refine_with_excl_list ik (intv : t) = function + | None -> intv + | Some (xs, range) -> + let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = + excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl + in + let excl_list = List.map (excl_to_intervalset ik range) xs in + List.fold_left (meet ik) intv excl_list + + let project ik p t = t + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let list_pair_arb = QCheck.small_list pair_arb in + let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in + let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list + in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) +end + +module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct + include D + + let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = fst @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = fst @@ D.shift_left ik x y + + let shift_right ik x y = fst @@ D.shift_right ik x y +end + +module IntIkind = struct let ikind () = Cil.IInt end +module Interval = IntervalFunctor (IntOps.BigIntOps) +module Bitfield = BitfieldFunctor (IntOps.BigIntOps) +module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) +module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) +module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) +struct + include Printable.Std + let name () = "integers" + type t = Ints_t.t [@@deriving eq, ord, hash] + type int_t = Ints_t.t + let top () = raise Unknown + let bot () = raise Error + let top_of ik = top () + let bot_of ik = bot () + let show (x: Ints_t.t) = Ints_t.to_string x + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) + let is_top _ = false + let is_bot _ = false + + let equal_to i x = if i > x then `Neq else `Top + let leq x y = x <= y + let join x y = if Ints_t.compare x y > 0 then x else y + let widen = join + let meet x y = if Ints_t.compare x y > 0 then y else x + let narrow = meet + + let of_bool x = if x then Ints_t.one else Ints_t.zero + let to_bool' x = x <> Ints_t.zero + let to_bool x = Some (to_bool' x) + let of_int x = x + let to_int x = Some x + + let neg = Ints_t.neg + let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) + let sub = Ints_t.sub + let mul = Ints_t.mul + let div = Ints_t.div + let rem = Ints_t.rem + let lt n1 n2 = of_bool (n1 < n2) + let gt n1 n2 = of_bool (n1 > n2) + let le n1 n2 = of_bool (n1 <= n2) + let ge n1 n2 = of_bool (n1 >= n2) + let eq n1 n2 = of_bool (n1 = n2) + let ne n1 n2 = of_bool (n1 <> n2) + let lognot = Ints_t.lognot + let logand = Ints_t.logand + let logor = Ints_t.logor + let logxor = Ints_t.logxor + let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) + let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) + let c_lognot n1 = of_bool (not (to_bool' n1)) + let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) + let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) + let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." + let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) + let invariant _ _ = Invariant.none (* TODO *) +end + +module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) +struct + include Integers(IntOps.Int64Ops) + let top () = raise Unknown + let bot () = raise Error + let leq = equal + let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y + let join x y = if equal x y then x else top () + let meet x y = if equal x y then x else bot () +end + +module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) +struct + type int_t = Base.int_t + include Lattice.FlatConf (struct + include Printable.DefaultConf + let top_name = "Unknown int" + let bot_name = "Error int" + end) (Base) + + let top_of ik = top () + let bot_of ik = bot () + + + let name () = "flat integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let starting ?(suppress_ovwarn=false) ikind x = top_of ikind + let ending ?(suppress_ovwarn=false) ikind x = top_of ikind + let maximal x = None + let minimal x = None + + let lift1 f x = match x with + | `Lifted x -> + (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> + (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) +struct + include Lattice.LiftPO (struct + include Printable.DefaultConf + let top_name = "MaxInt" + let bot_name = "MinInt" + end) (Base) + type int_t = Base.int_t + let top_of ik = top () + let bot_of ik = bot () + include StdTop (struct type nonrec t = t let top_of = top_of end) + + let name () = "lifted integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let lift1 f x = match x with + | `Lifted x -> `Lifted (f x) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> `Lifted (f x y) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Flattened = Flat (Integers (IntOps.Int64Ops)) +module Lifted = Lift (Integers (IntOps.Int64Ops)) + +module Reverse (Base: IkindUnawareS) = +struct + include Base + include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) +end + +module BISet = struct + include SetDomain.Make (IntOps.BigIntOps) + let is_singleton s = cardinal s = 1 +end + +(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) +module Exclusion = +struct + module R = Interval32 + (* We use these types for the functions in this module to make the intended meaning more explicit *) + type t = Exc of BISet.t * Interval32.t + type inc = Inc of BISet.t [@@unboxed] + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) + + let cardinality_BISet s = + Z.of_int (BISet.cardinal s) + + let leq_excl_incl (Exc (xs, r)) (Inc ys) = + (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) + let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in + let card_b = cardinality_BISet ys in + if Z.compare lower_bound_cardinality_a card_b > 0 then + false + else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) + let min_a = min_of_range r in + let max_a = max_of_range r in + GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) + + let leq (Exc (xs, r)) (Exc (ys, s)) = + let min_a, max_a = min_of_range r, max_of_range r in + let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) + if not excluded_check + then false + else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) + if R.leq r s then true + else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) + then + let min_b, max_b = min_of_range s, max_of_range s in + let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) + if Z.compare min_a min_b < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) + else + true + in + let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) + if Z.compare max_b max_a < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) + else + true + in + leq1 && (leq2 ()) + else + false + end + end +end + +module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) +struct + module S = BISet + module R = Interval32 (* range for exclusion *) + + (* Ikind used for intervals representing the domain *) + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + + type t = [ + | `Excluded of S.t * R.t + | `Definite of Z.t + | `Bot + ] [@@deriving eq, ord, hash] + type int_t = Z.t + let name () = "def_exc" + + + let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) + let top () = `Excluded (S.empty (), top_range) + let bot () = `Bot + let top_of ik = `Excluded (S.empty (), size ik) + let bot_of ik = bot () + + let show x = + let short_size x = "("^R.show x^")" in + match x with + | `Bot -> "Error int" + | `Definite x -> Z.to_string x + (* Print the empty exclusion as if it was a distinct top element: *) + | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l + (* Prepend the exclusion sets with something: *) + | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let maximal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.max_of_range r) + | `Bot -> None + + let minimal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.min_of_range r) + | `Bot -> None + + let in_range r i = + if Z.compare i Z.zero < 0 then + let lowerb = Exclusion.min_of_range r in + Z.compare lowerb i <= 0 + else + let upperb = Exclusion.max_of_range r in + Z.compare i upperb <= 0 + + let is_top x = x = top () + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Definite x -> if i = x then `Eq else `Neq + | `Excluded (s,r) -> if S.mem i s then `Neq else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function + | `Excluded (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + `Excluded (s, r) + else if ik = IBool then (* downcast to bool *) + if S.mem Z.zero s then + `Definite Z.one + else + `Excluded (S.empty(), r') + else + (* downcast: may overflow *) + (* let s' = S.map (Size.cast ik) s in *) + (* We want to filter out all i in s' where (t)x with x in r could be i. *) + (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) + (* S.diff s' s, r' *) + (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) + `Excluded (S.empty (), r') + | `Definite x -> `Definite (Size.cast ik x) + | `Bot -> `Bot + + (* Wraps definite values and excluded values according to the ikind. + * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. + * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. + *) + let norm ik v = + match v with + | `Excluded (s, r) -> + let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in + (* If no overflow occurred, just return x *) + if not possibly_overflowed then ( + v + ) + (* Else, if an overflow might have occurred but we should just ignore it *) + else if should_ignore_overflow ik then ( + let r = size ik in + (* filter out excluded elements that are not in the range *) + let mapped_excl = S.filter (in_range r) s in + `Excluded (mapped_excl, r) + ) + (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) + else if not (should_wrap ik) then ( + top_of ik + ) else ( + (* Else an overflow occurred that we should treat with wrap-around *) + let r = size ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in + match ik with + | IBool -> + begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with + | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) + | true, false -> `Definite Z.one (* Not {0} -> 1 *) + | false, true -> `Definite Z.zero (* Not {1} -> 0 *) + | true, true -> `Bot (* Not {0, 1} -> bot *) + end + | ik -> + `Excluded (mapped_excl, r) + ) + | `Definite x -> + let min, max = Size.range ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + if should_wrap ik then ( + cast_to ik v + ) + else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( + v + ) + else if should_ignore_overflow ik then ( + M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + `Bot + ) + else ( + top_of ik + ) + | `Bot -> `Bot + + let leq x y = match (x,y) with + (* `Bot <= x is always true *) + | `Bot, _ -> true + (* Anything except bot <= bot is always false *) + | _, `Bot -> false + (* Two known values are leq whenever equal *) + | `Definite (x: int_t), `Definite y -> x = y + (* A definite value is leq all exclusion sets that don't contain it *) + | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) + (* No finite exclusion set can be leq than a definite value *) + | `Excluded (xs, xr), `Definite d -> + Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) + | `Excluded (xs,xr), `Excluded (ys,yr) -> + Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) + + let join' ?range ik x y = + match (x,y) with + (* The least upper bound with the bottom element: *) + | `Bot, x -> x + | x, `Bot -> x + (* The case for two known values: *) + | `Definite (x: int_t), `Definite y -> + (* If they're equal, it's just THAT value *) + if x = y then `Definite x + (* Unless one of them is zero, we can exclude it: *) + else + let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in + `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) + (* A known value and an exclusion set... the definite value should no + * longer be excluded: *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> + if not (in_range r x) then + let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in + `Excluded (S.remove x s, R.join a r) + else + `Excluded (S.remove x s, r) + (* For two exclusion sets, only their intersection can be excluded: *) + | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) + + let join ik = join' ik + + + let widen ik x y = + if get_def_exc_widen_by_join () then + join' ik x y + else if equal x y then + x + else + join' ~range:(size ik) ik x y + + + let meet ik x y = + match (x,y) with + (* Greatest LOWER bound with the least element is trivial: *) + | `Bot, _ -> `Bot + | _, `Bot -> `Bot + (* Definite elements are either equal or the glb is bottom *) + | `Definite x, `Definite y -> if x = y then `Definite x else `Bot + (* The glb of a definite element and an exclusion set is either bottom or + * just the element itself, if it isn't in the exclusion set *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x + (* The greatest lower bound of two exclusion sets is their union, this is + * just DeMorgans Law *) + | `Excluded (x,r1), `Excluded (y,r2) -> + let r' = R.meet r1 r2 in + let s' = S.union x y |> S.filter (in_range r') in + `Excluded (s', r') + + let narrow ik x y = x + + let of_int ik x = norm ik @@ `Definite x + let to_int x = match x with + | `Definite x -> Some x + | _ -> None + + let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) + + let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) + let of_bool = of_bool_cmp + let to_bool x = + match x with + | `Definite x -> Some (IntOps.BigIntOps.to_bool x) + | `Excluded (s,r) when S.mem Z.zero s -> Some true + | _ -> None + let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in + norm ik @@ (`Excluded (ex, r)) + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let of_excl_list t l = + let r = size t in (* elements in l are excluded from the full range of t! *) + `Excluded (List.fold_right S.add l (S.empty ()), r) + let is_excl_list l = match l with `Excluded _ -> true | _ -> false + let to_excl_list (x:t) = match x with + | `Definite _ -> None + | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) + | `Bot -> None + + let to_incl_list x = match x with + | `Definite x -> Some [x] + | `Excluded _ -> None + | `Bot -> None + + let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) + (* If the Int64 might overflow on us during computation, we instead go to top_range *) + match R.minimal r, R.maximal r with + | _ -> + let rf m = (size % Size.min_for % f) (m r) in + let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in + R.join r1 r2 + + (* Default behaviour for unary operators, simply maps the function to the + * DefExc data structure. *) + let lift1 f ik x = norm ik @@ match x with + | `Excluded (s,r) -> + let s' = S.map f s in + `Excluded (s', apply_range f r) + | `Definite x -> `Definite (f x) + | `Bot -> `Bot + + let lift2 f ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite _ + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (f x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + (* Default behaviour for binary operators that are injective in either + * argument, so that Exclusion Sets can be used: *) + let lift2_inj f ik x y = + let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in + norm ik @@ + match x,y with + (* If both are exclusion sets, there isn't anything we can do: *) + | `Excluded _, `Excluded _ -> top () + (* A definite value should be applied to all members of the exclusion set *) + | `Definite x, `Excluded (s,r) -> def_exc f x s r + (* Same thing here, but we should flip the operator to map it properly *) + | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r + (* The good case: *) + | `Definite x, `Definite y -> `Definite (f x y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The equality check: *) + let eq ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x equal to an exclusion set, if it is a member then NO otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x = y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The inequality check: *) + let ne ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x <> y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x + let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y + + let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y + let mul ?no_ov ik x y = norm ik @@ match x, y with + | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x + | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y + | `Definite a, `Excluded (s,r) + (* Integer multiplication with even numbers is not injective. *) + (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) + | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) + | _ -> lift2_inj Z.mul ik x y + let div ?no_ov ik x y = lift2 Z.div ik x y + let rem ik x y = lift2 Z.rem ik x y + + (* Comparison handling copied from Enums. *) + let handle_bot x y f = match x, y with + | `Bot, `Bot -> `Bot + | `Bot, _ + | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> f () + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let lognot = lift1 Z.lognot + + let logand ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite i -> + (* Except in two special cases *) + if Z.equal i Z.zero then + `Definite Z.zero + else if Z.equal i Z.one then + of_interval IBool (Z.zero, Z.one) + else + top () + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + norm ik @@ lift2 shift_op_big_int ik x y + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + (* TODO: lift does not treat Not {0} as true. *) + let c_logand ik x y = + match to_bool x, to_bool y with + | Some false, _ + | _, Some false -> + of_bool ik false + | _, _ -> + lift2 IntOps.BigIntOps.c_logand ik x y + let c_logor ik x y = + match to_bool x, to_bool y with + | Some true, _ + | _, Some true -> + of_bool ik true + | _, _ -> + lift2 IntOps.BigIntOps.c_logor ik x y + let c_lognot ik = eq ik (of_int ik Z.zero) + + let invariant_ikind e ik (x:t) = + match x with + | `Definite x -> + IntInvariant.of_int e ik x + | `Excluded (s, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let si = IntInvariant.of_excl_list e ik (S.elements s) in + Invariant.(ri && si) + | `Bot -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + let excluded s = from_excl ik s in + let definite x = of_int ik x in + let shrink = function + | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) + | `Bot -> empty + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map excluded (S.arbitrary ()); + 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); + 1, QCheck.always `Bot + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = a + let refine_with_interval ik a b = match a, b with + | x, Some(i) -> meet ik x (of_interval ik i) + | _ -> a + let refine_with_excl_list ik a b = match a, b with + | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end + +(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) +module Enums : S with type int_t = Z.t = struct + module R = Interval32 (* range for exclusion *) + + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) + + type int_t = Z.t + let name () = "enums" + let bot () = failwith "bot () not implemented for Enums" + let top () = failwith "top () not implemented for Enums" + let bot_of ik = Inc (BISet.empty ()) + let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) + let top_of ik = + match ik with + | IBool -> top_bool + | _ -> Exc (BISet.empty (), size ik) + + let range ik = Size.range ik + + (* + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) + let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 + + let show = function + | Inc xs when BISet.is_empty xs -> "bot" + | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" + | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + (* Normalization function for enums, that handles overflows for Inc. + As we do not compute on Excl, we do not have to perform any overflow handling for it. *) + let norm ikind v = + let min, max = range ikind in + (* Whether the value v lies within the values of the specified ikind. *) + let value_in_ikind v = + Z.compare min v <= 0 && Z.compare v max <= 0 + in + match v with + | Inc xs when BISet.for_all value_in_ikind xs -> v + | Inc xs -> + if should_wrap ikind then + Inc (BISet.map (Size.cast ikind) xs) + else if should_ignore_overflow ikind then + Inc (BISet.filter value_in_ikind xs) + else + top_of ikind + | Exc (xs, r) -> + (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: + let range_in_ikind r = + R.leq r (size ikind) + in + let r_min, r_max = min_of_range r, max_of_range r in + assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) + begin match ikind with + | IBool -> + begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with + | false, false -> top_bool (* Not {} -> {0, 1} *) + | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) + | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) + | true, true -> bot_of ikind (* Not {0, 1} -> bot *) + end + | _ -> + v + end + + + let equal_to i = function + | Inc x -> + if BISet.mem i x then + if BISet.is_singleton x then `Eq + else `Top + else `Neq + | Exc (x, r) -> + if BISet.mem i x then `Neq + else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with + | Exc (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + Exc (s, r) + else if ik = IBool then (* downcast to bool *) + if BISet.mem Z.zero s then + Inc (BISet.singleton Z.one) + else + Exc (BISet.empty(), r') + else (* downcast: may overflow *) + Exc ((BISet.empty ()), r') + | Inc xs -> + let casted_xs = BISet.map (Size.cast ik) xs in + if Cil.isSigned ik && not (BISet.equal xs casted_xs) + then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) + else Inc casted_xs + + let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) + + let of_interval ?(suppress_ovwarn=false) ik (x, y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in + norm ik @@ (Exc (ex, r)) + + let join _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.union x y) + | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) + | Exc (x,r), Inc y + | Inc y, Exc (x,r) -> + let r = if BISet.is_empty y + then r + else + let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in + let range = R.join min_el_range max_el_range in + R.join r range + in + Exc (BISet.diff x y, r) + + let meet _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.inter x y) + | Exc (x,r1), Exc (y,r2) -> + let r = R.meet r1 r2 in + let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in + let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in + (* We remove those elements from the exclusion set that do not fit in the range anyway *) + let excl = BISet.union (filter_by_range x) (filter_by_range y) in + Exc (excl, r) + | Inc x, Exc (y,r) + | Exc (y,r), Inc x -> Inc (BISet.diff x y) + + let widen = join + let narrow = meet + let leq a b = + match a, b with + | Inc xs, Exc (ys, r) -> + if BISet.is_empty xs + then true + else + let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in + let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in + (* Check that the xs fit into the range r *) + Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && + (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) + BISet.for_all (fun x -> not (BISet.mem x ys)) xs + | Inc xs, Inc ys -> + BISet.subset xs ys + | Exc (xs, r), Exc (ys, s) -> + Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) + | Exc (xs, r), Inc ys -> + Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) + + let handle_bot x y f = match is_bot x, is_bot y with + | false, false -> f () + | true, false + | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | true, true -> Inc (BISet.empty ()) + + let lift1 f ikind v = norm ikind @@ match v with + | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) + | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) + | _ -> top_of ikind + + let lift2 f (ikind: Cil.ikind) u v = + handle_bot u v (fun () -> + norm ikind @@ match u, v with + | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) + | _,_ -> top_of ikind) + + let lift2 f ikind a b = + try lift2 f ikind a b with Division_by_zero -> top_of ikind + + let neg ?no_ov = lift1 Z.neg + let add ?no_ov ikind a b = + match a, b with + | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,y -> lift2 Z.add ikind x y + let sub ?no_ov = lift2 Z.sub + let mul ?no_ov ikind a b = + match a, b with + | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b + | x,y -> lift2 Z.mul ikind x y + + let div ?no_ov ikind a b = match a, b with + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | x,y -> lift2 Z.div ikind x y + + let rem = lift2 Z.rem + + let lognot = lift1 Z.lognot + let logand = lift2 Z.logand + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + handle_bot x y (fun () -> + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + lift2 shift_op_big_int ik x y) + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + + let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) + let to_bool = function + | Inc e when BISet.is_empty e -> None + | Exc (e,_) when BISet.is_empty e -> None + | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false + | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true + | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true + | _ -> None + let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None + + let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None + let of_excl_list ik xs = + let min_ik, max_ik = Size.range ik in + let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in + norm ik @@ Exc (exc, size ik) + let is_excl_list = BatOption.is_some % to_excl_list + let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let c_lognot ik x = + if is_bot x + then x + else + match to_bool x with + | Some b -> of_bool ik (not b) + | None -> top_bool + + let c_logand = lift2 IntOps.BigIntOps.c_logand + let c_logor = lift2 IntOps.BigIntOps.c_logor + let maximal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) + | Exc (excl,r) -> + let rec decrement_while_contained v = + if BISet.mem v excl + then decrement_while_contained (Z.pred v) + else v + in + let range_max = Exclusion.max_of_range r in + Some (decrement_while_contained range_max) + | _ (* bottom case *) -> None + + let minimal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) + | Exc (excl,r) -> + let rec increment_while_contained v = + if BISet.mem v excl + then increment_while_contained (Z.succ v) + else v + in + let range_min = Exclusion.min_of_range r in + Some (increment_while_contained range_min) + | _ (* bottom case *) -> None + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let eq ik x y = + handle_bot x y (fun () -> + match x, y with + | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) + | _, _ -> + if is_bot (meet ik x y) then + (* If the meet is empty, there is no chance that concrete values are equal *) + of_bool ik false + else + top_bool) + + let ne ik x y = c_lognot ik (eq ik x y) + + let invariant_ikind e ik x = + match x with + | Inc ps -> + IntInvariant.of_incl_list e ik (BISet.elements ps) + | Exc (ns, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in + Invariant.(ri && nsi) + + + let arbitrary ik = + let open QCheck.Iter in + let neg s = of_excl_list ik (BISet.elements s) in + let pos s = norm ik (Inc s) in + let shrink = function + | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) + | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map neg (BISet.arbitrary ()); + 10, QCheck.map pos (BISet.arbitrary ()); + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = + let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in + match a, b with + | Inc e, None -> bot_of ik + | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) + | _ -> a + + let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) + + let refine_with_excl_list ik a b = + match b with + | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + + let refine_with_incl_list ik a b = + match a, b with + | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) + | _ -> a + + let project ik p t = t +end + +module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = +struct + let name () = "congruences" + type int_t = Z.t + + (* represents congruence class of c mod m, None is bot *) + type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] + + let ( *: ) = Z.mul + let (+:) = Z.add + let (-:) = Z.sub + let (%:) = Z.rem + let (/:) = Z.div + let (=:) = Z.equal + let (<:) x y = Z.compare x y < 0 + let (>:) x y = Z.compare x y > 0 + let (<=:) x y = Z.compare x y <= 0 + let (>=:) x y = Z.compare x y >= 0 + (* a divides b *) + let ( |: ) a b = + if a =: Z.zero then false else (b %: a) =: Z.zero + + let normalize ik x = + match x with + | None -> None + | Some (c, m) -> + if m =: Z.zero then + if should_wrap ik then + Some (Size.cast ik c, m) + else + Some (c, m) + else + let m' = Z.abs m in + let c' = c %: m' in + if c' <: Z.zero then + Some (c' +: m', m') + else + Some (c' %: m', m') + + let range ik = Size.range ik + + let top () = Some (Z.zero, Z.one) + let top_of ik = Some (Z.zero, Z.one) + let bot () = None + let bot_of ik = bot () + + let show = function ik -> match ik with + | None -> "⟂" + | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c + | Some (c, m) -> + let a = if c =: Z.zero then "" else Z.to_string c in + let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in + let c = if a = "" || b = "" then "" else "+" in + a^c^b + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let is_top x = x = top () + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq + | Some (a, b) -> if i %: b =: a then `Top else `Neq + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero + | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 + (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 + Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) + + let leq x y = + let res = leq x y in + if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; + res + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (c1,m1), Some (c2,m2) -> + let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in + normalize ik (Some (c1, m3)) + + let join ik (x:t) y = + let res = join ik x y in + if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; + res + + + let meet ik x y = + (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) + let congruence_series a c m = + let rec next a1 c1 a2 c2 = + if a2 |: a1 then (a2, c2) + else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) + in next m Z.zero a c + in + let simple_case i c m = + if m |: (i -: c) + then Some (i, Z.zero) else None + in + match x, y with + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 + | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 + | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> + let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in + normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) + | _ -> None + + let meet ik x y = + let res = meet ik x y in + if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; + res + + let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None + let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) + let zero = Some (Z.zero, Z.zero) + let one = Some (Z.one, Z.zero) + let top_bool = top() + + let of_bool _ik = function true -> one | false -> zero + + let to_bool (a: t) = match a with + | None -> None + | x when equal zero x -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = top() + + let ending = starting + + let of_congruence ik (c,m) = normalize ik @@ Some(c,m) + + let maximal t = match t with + | Some (x, y) when y =: Z.zero -> Some x + | _ -> None + + let minimal t = match t with + | Some (x,y) when y =: Z.zero -> Some x + | _ -> None + + (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) + let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = + match x with + | None -> None + | Some (c, m) when m =: Z.zero -> + let c' = Size.cast t c in + (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) + (* We go with GCC behavior here: *) + (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) + (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) + (* Clang behaves the same but they never document that anywhere *) + Some (c', m) + | _ -> + let (min_t, max_t) = range t in + let p ikorg = + let (min_ikorg, max_ikorg) = range ikorg in + ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) + in + match torg with + | Some (Cil.TInt (ikorg, _)) when p ikorg -> + if M.tracing then M.trace "cong-cast" "some case"; + x + | _ -> top () + + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = + let pretty_bool _ x = Pretty.text (string_of_bool x) in + let res = cast_to ?torg ?no_ov t x in + if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; + res + + let widen = join + + let widen ik x y = + let res = widen ik x y in + if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; + res + + let narrow = meet + + let log f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) + let c_logand = log (&&) + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let shift_right _ _ _ = top() + + let shift_right ik x y = + let res = shift_right ik x y in + if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; + res + + let shift_left ik x y = + (* Naive primality test *) + (* let is_prime n = + let n = Z.abs n in + let rec is_prime' d = + (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) + in + not (n =: Z.one) && is_prime' (Z.of_int 2) + in *) + match x, y with + | None, None -> None + | None, _ + | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik + | Some (c, m), Some (c', m') -> + let (_, max_ik) = range ik in + if m =: Z.zero && m' =: Z.zero then + normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) + else + let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) + (* TODO: commented out because fails test with _Bool *) + (* if is_prime (m' +: Z.one) then + normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) + else *) + normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) + + let shift_left ik x y = + let res = shift_left ik x y in + if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; + res + + (* Handle unsigned overflows. + From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. + The congruence modulo b may not persist on an overflow. *) + let handle_overflow ik (c, m) = + if m =: Z.zero then + normalize ik (Some (c, m)) + else + (* Find largest m'=2^k (for some k) such that m is divisible by m' *) + let tz = Z.trailing_zeros m in + let m' = Z.shift_left Z.one tz in + + let max = (snd (Size.range ik)) +: Z.one in + if m' >=: max then + (* if m' >= 2 ^ {bitlength}, there is only one value in range *) + let c' = c %: max in + Some (c', Z.zero) + else + normalize ik (Some (c, m')) + + let mul ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) + in + match x, y with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) when no_ov -> + Some (no_ov_case (c1, m1) (c2, m2)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b ) + | _ -> top () + + let mul ?no_ov ik x y = + let res = mul ?no_ov ik x y in + if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; + res + + let neg ?(no_ov=false) ik x = + match x with + | None -> bot() + | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x + + let add ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 +: c2, Z.gcd m1 m2 + in + match (x, y) with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some a, Some b when no_ov -> + normalize ik (Some (no_ov_case a b)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b) + | _ -> top () + + + let add ?no_ov ik x y = + let res = add ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "add : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) + + + let sub ?no_ov ik x y = + let res = sub ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let lognot ik x = match x with + | None -> None + | Some (c, m) -> + if (Cil.isSigned ik) then + sub ik (neg ik x) one + else + let (_, max_ik) = range ik in + Some (Z.sub max_ik c, m) + + (** The implementation of the bit operations could be improved based on the master’s thesis + 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. + see: http://www.es.mdh.se/pdf_publications/948.pdf *) + let bit2 f ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) + else top () + + let logor ik x y = bit2 Z.logor ik x y + + let logand ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then + (* both arguments constant *) + Some (Z.logand c c', Z.zero) + else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then + (* x & 1 and x == c (mod 2*z) *) + (* Value is equal to LSB of c *) + Some (Z.logand c c', Z.zero) + else + top () + + let logxor ik x y = bit2 Z.logxor ik x y + + let rem ik x y = + match x, y with + | None, None -> bot() + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some(c2, m2) -> + if m2 =: Z.zero then + if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then + Some (c1 %: c2, Z.zero) + else + normalize ik (Some (c1, (Z.gcd m1 c2))) + else + normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) + + let rem ik x y = let res = rem ik x y in + if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; + res + + let div ?(no_ov=false) ik x y = + match x,y with + | None, None -> bot () + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, x when leq zero x -> top () + | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () + | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) + | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) + | _, _ -> top () + + + let div ?no_ov ik x y = + let res = div ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty + res ; + res + + let ne ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) + | x, y -> if meet ik x y = None then of_bool ik true else top_bool + + let eq ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) + | x, y -> if meet ik x y <> None then top_bool else of_bool ik false + + let comparison ik op x y = match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) -> + if m1 =: Z.zero && m2 =: Z.zero then + if op c1 c2 then of_bool ik true else of_bool ik false + else + top_bool + + let ge ik x y = comparison ik (>=:) x y + + let ge ik x y = + let res = ge ik x y in + if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let le ik x y = comparison ik (<=:) x y + + let le ik x y = + let res = le ik x y in + if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let gt ik x y = comparison ik (>:) x y + + + let gt ik x y = + let res = gt ik x y in + if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; + res + + let lt ik x y = comparison ik (<:) x y + + let lt ik x y = + let res = lt ik x y in + if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; + res + + let invariant_ikind e ik x = + match x with + | x when is_top x -> Invariant.top () + | Some (c, m) when m =: Z.zero -> + IntInvariant.of_int e ik c + | Some (c, m) -> + let open Cil in + let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in + Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) + | None -> Invariant.none + + let arbitrary ik = + let open QCheck in + let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in + let cong_arb = pair int_arb int_arb in + let of_pair ik p = normalize ik (Some p) in + let to_pair = Option.get in + set_print show (map ~rev:to_pair (of_pair ik) cong_arb) + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =: Z.zero then + if c <: x || c >: y then None else Some (c, Z.zero) + else + let rcx = x +: ((c -: x) %: Z.abs m) in + let lcy = y -: ((y -: c) %: Z.abs m) in + if rcx >: lcy then None + else if rcx =: lcy then Some (rcx, Z.zero) + else cong + | _ -> None + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = + let pretty_intv _ i = + match i with + | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u + | _ -> Pretty.text ("Display Error") in + let refn = refine_with_interval ik cong intv in + if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; + refn + + let refine_with_congruence ik a b = meet ik a b + let refine_with_excl_list ik a b = a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end + +module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct + + include D + + let lift v = (v, {overflow=false; underflow=false}) + + let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = lift @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = lift @@ D.shift_left ik x y + + let shift_right ik x y = lift @@ D.shift_right ik x y + +end + + + + + + +(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) +(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) +module IntDomTupleImpl = struct + include Printable.Std (* for default invariant, tag, ... *) + + open Batteries + type int_t = Z.t + module I1 = SOverflowLifter (DefExc) + module I2 = Interval + module I3 = SOverflowLifter (Enums) + module I4 = SOverflowLifter (Congruence) + module I5 = IntervalSetFunctor (IntOps.BigIntOps) + module I6 = BitfieldFunctor (IntOps.BigIntOps) + + type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option + [@@deriving eq, ord, hash] + + let name () = "intdomtuple" + + (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) + let no_interval = Tuple6.map2 (const None) + let no_intervalSet = Tuple6.map5 (const None) + + type 'a m = (module SOverflow with type t = 'a) + type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) + + (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) + type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) + type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) + type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) + + type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) + type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) + type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] + type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] + type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] + type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) + let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) + let create r x = (* use where values are introduced *) + create r x (int_precision_from_node_or_config ()) + let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) + let create2 r x = (* use where values are introduced *) + create2 r x (int_precision_from_node_or_config ()) + + let no_overflow ik = function + | Some(_, {underflow; overflow}) -> not (underflow || overflow) + | _ -> false + + let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = + let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in + if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( + let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in + let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in + let underflow = underflow_intv && underflow_intv_set in + let overflow = overflow_intv && overflow_intv_set in + set_overflow_flag ~cast ~underflow ~overflow ik; + ); + no_ov + + let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = + let f b g = if b then Some (g x) else None in + let map x = Option.map fst x in + let intv = f p2 @@ r.fi2_ovc (module I2) in + let intv_set = f p5 @@ r.fi2_ovc (module I5) in + ignore (check_ov ~cast:false ik intv intv_set); + map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) + + let create2_ovc ik r x = (* use where values are introduced *) + create2_ovc ik r x (int_precision_from_node_or_config ()) + + + let opt_map2 f ?no_ov = + curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None + + let to_list x = Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) + let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) + + let exists = function + | (Some true, _, _, _, _,_) + | (_, Some true, _, _, _,_) + | (_, _, Some true, _, _,_) + | (_, _, _, Some true, _,_) + | (_, _, _, _, Some true,_) + | (_, _, _, _, _, Some true) + -> true + | _ -> + false + + let for_all = function + | (Some false, _, _, _, _,_) + | (_, Some false, _, _, _,_) + | (_, _, Some false, _, _,_) + | (_, _, _, Some false, _,_) + | (_, _, _, _, Some false,_) + | (_, _, _, _, _, Some false) + -> + false + | _ -> + true + + (* f0: constructors *) + let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () + let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () + let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } + let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } + let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } + let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} + let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } + let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } + let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } + let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } + let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } + + let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_congruence ik a cong + , opt I2.refine_with_congruence ik b cong + , opt I3.refine_with_congruence ik c cong + , opt I4.refine_with_congruence ik d cong + , opt I5.refine_with_congruence ik e cong + , opt I6.refine_with_congruence ik f cong + ) + + let refine_with_interval ik (a, b, c, d, e,f) intv = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_interval ik a intv + , opt I2.refine_with_interval ik b intv + , opt I3.refine_with_interval ik c intv + , opt I4.refine_with_interval ik d intv + , opt I5.refine_with_interval ik e intv + , opt I6.refine_with_interval ik f intv ) + + let refine_with_excl_list ik (a, b, c, d, e,f) excl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_excl_list ik a excl + , opt I2.refine_with_excl_list ik b excl + , opt I3.refine_with_excl_list ik c excl + , opt I4.refine_with_excl_list ik d excl + , opt I5.refine_with_excl_list ik e excl + , opt I6.refine_with_excl_list ik f excl ) + + let refine_with_incl_list ik (a, b, c, d, e,f) incl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_incl_list ik a incl + , opt I2.refine_with_incl_list ik b incl + , opt I3.refine_with_incl_list ik c incl + , opt I4.refine_with_incl_list ik d incl + , opt I5.refine_with_incl_list ik e incl + , opt I6.refine_with_incl_list ik f incl ) + + + let mapp r (a, b, c, d, e, f) = + let map = BatOption.map in + ( map (r.fp (module I1)) a + , map (r.fp (module I2)) b + , map (r.fp (module I3)) c + , map (r.fp (module I4)) d + , map (r.fp (module I5)) e + , map (r.fp (module I6)) f) + + + let mapp2 r (a, b, c, d, e, f) = + BatOption. + ( map (r.fp2 (module I1)) a + , map (r.fp2 (module I2)) b + , map (r.fp2 (module I3)) c + , map (r.fp2 (module I4)) d + , map (r.fp2 (module I5)) e + , map (r.fp2 (module I6)) f) + + + (* exists/for_all *) + let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } + let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } + let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } + let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } + + let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + ( opt_map2 (r.f2p (module I1)) xa ya + , opt_map2 (r.f2p (module I2)) xb yb + , opt_map2 (r.f2p (module I3)) xc yc + , opt_map2 (r.f2p (module I4)) xd yd + , opt_map2 (r.f2p (module I5)) xe ye + , opt_map2 (r.f2p (module I6)) xf yf) + + (* f2p: binary projections *) + let (%%) f g x = f % (g x) (* composition for binary function g *) + + let leq = + for_all + %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} + + let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) + + let to_excl_list x = + let merge ps = + let (vs, rs) = List.split ps in + let (mins, maxs) = List.split rs in + (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge + + let to_incl_list x = + let hd l = match l with h::t -> h | _ -> [] in + let tl l = match l with h::t -> t | _ -> [] in + let a y = BatSet.of_list (hd y) in + let b y = BatList.map BatSet.of_list (tl y) in + let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge + + let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in + if n = 1 then Some (List.hd xs) + else ( + if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) + None + ) + let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } + + let pretty () x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) + | _ -> + mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x + |> to_list + |> (fun xs -> + text "(" ++ ( + try + List.reduce (fun a b -> a ++ text "," ++ b) xs + with Invalid_argument _ -> + nil) + ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) + + let refine_functions ik : (t -> t) list = + let maybe reffun ik domtup dom = + match dom with Some y -> reffun ik domtup y | _ -> domtup + in + [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e,f) b); (* TODO: get interval across all domains with minimal and maximal *) + (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e,f) d)] + + let refine ik ((a, b, c, d, e,f) : t ) : t = + let dt = ref (a, b, c, d, e,f) in + (match get_refinement () with + | "never" -> () + | "once" -> + List.iter (fun f -> dt := f !dt) (refine_functions ik); + | "fixpoint" -> + let quit_loop = ref false in + while not !quit_loop do + let old_dt = !dt in + List.iter (fun f -> dt := f !dt) (refine_functions ik); + quit_loop := equal old_dt !dt; + if is_bot !dt then dt := bot_of ik; quit_loop := true; + if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; + done; + | _ -> () + ); !dt + + + (* map with overflow check *) + let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = + let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in + let intv = map (r.f1_ovc (module I2)) b in + let intv_set = map (r.f1_ovc (module I5)) e in + let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a + , BatOption.map fst intv + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d + , BatOption.map fst intv_set + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) + + (* map2 with overflow check *) + let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in + let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in + let no_ov = check_ov ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya + , BatOption.map fst intv + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd + , BatOption.map fst intv_set + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) + + let map ik r (a, b, c, d, e, f) = + refine ik + BatOption. + ( map (r.f1 (module I1)) a + , map (r.f1 (module I2)) b + , map (r.f1 (module I3)) c + , map (r.f1 (module I4)) d + , map (r.f1 (module I5)) e + , map (r.f1 (module I6)) f) + + let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + let r = + ( opt_map2 (r.f2 (module I1)) xa ya + , opt_map2 (r.f2 (module I2)) xb yb + , opt_map2 (r.f2 (module I3)) xc yc + , opt_map2 (r.f2 (module I4)) xd yd + , opt_map2 (r.f2 (module I5)) xe ye + , opt_map2 (r.f2 (module I6)) xf yf) + in + if norefine then r else refine ik r + + + (* f1: unary ops *) + let neg ?no_ov ik = + mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} + + let lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} + + let c_lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = + mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} + + (* fp: projections *) + let equal_to i x = + let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple6.enum |> List.of_enum |> List.filter_map identity in + if List.mem `Eq xs then `Eq else + if List.mem `Neq xs then `Neq else + `Top + + let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } + let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } + let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } + (* others *) + let show x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v + | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x + |> to_list + |> String.concat "; " + let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } + + (* `map/opt_map` are used by `project` *) + let opt_map b f = + curry @@ function None, true -> f | x, y when y || b -> x | _ -> None + let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = + ( opt_map keep (r.f3 (module I1)) i1 b1 + , opt_map keep (r.f3 (module I2)) i2 b2 + , opt_map keep (r.f3 (module I3)) i3 b3 + , opt_map keep (r.f3 (module I4)) i4 b4 + , opt_map keep (r.f3 (module I5)) i5 b5 + , opt_map keep (r.f3 (module I6)) i6 b6) + + (** Project tuple t to precision p + * We have to deactivate IntDomains after the refinement, since we might + * lose information if we do it before. E.g. only "Interval" is active + * and shall be projected to only "Def_Exc". By seting "Interval" to None + * before refinement we have no information for "Def_Exc". + * + * Thus we have 3 Steps: + * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element + * 2. Refine the padded t + * 3. Set elements of t to `None` if p is false for this element + * + * Side Note: + * ~keep is used to reuse `map/opt_map` for Step 1 and 3. + * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. + * This way we won't loose any information for the refinement. + * ~keep:false will set the elements to `None` as defined by p *) + let project ik (p: int_precision) t = + let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in + let t_refined = refine ik t_padded in + map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p + + + (* f2: binary ops *) + let join ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} + + let meet ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} + + let widen ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} + + let narrow ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} + + let add ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} + + let sub ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} + + let mul ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} + + let div ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} + + let rem ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} + + let lt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} + + let gt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} + + let le ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} + + let ge ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} + + let eq ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} + + let ne ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} + + let logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} + + let logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} + + let logxor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} + + let shift_left ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} + + let shift_right ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} + + let c_logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} + + let c_logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} + + + (* printing boilerplate *) + let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y + let printXml f x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) + | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) + + let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = + (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) + let simplify_int fallback = + match to_int x with + | Some v -> + (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) + IntInvariant.of_int e ik v + | None -> + fallback () + in + let simplify_all () = + match to_incl_list x with + | Some ps -> + (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) + IntInvariant.of_incl_list e ik ps + | None -> + (* Get interval bounds from all domains (intervals and exclusion set ranges). *) + let min = minimal x in + let max = maximal x in + let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) + (* "Refine" out-of-bounds exclusions for simpler output. *) + let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in + let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in + Invariant.( + IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) + IntInvariant.of_excl_list e ik ns && + Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) + Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) + ) + in + let simplify_none () = + let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in + List.fold_left (fun a i -> + Invariant.(a && i) + ) (Invariant.top ()) is + in + match GobConfig.get_string "ana.base.invariant.int.simplify" with + | "none" -> simplify_none () + | "int" -> simplify_int simplify_none + | "all" -> simplify_int simplify_all + | _ -> assert false + + let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) + + let relift (a, b, c, d, e, f) = + (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) +end + +module IntDomTuple = +struct + module I = IntDomLifter (IntDomTupleImpl) + include I + + let top () = failwith "top in IntDomTuple not supported. Use top_of instead." + let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} + + let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} +end + +let of_const (i, ik, str) = IntDomTuple.of_int ik i From d40585374f57684474fca60bb6c6100627a418f0 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Thu, 14 Nov 2024 20:26:40 +0100 Subject: [PATCH 029/111] Revert "refine hotfix2" This reverts commit ff8c4c7fa6b4f149262c57f5322186b88c1543a7. --- src/cdomain/value/cdomains/intDomain.ml | 8654 +++++++++++------------ 1 file changed, 4327 insertions(+), 4327 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4788e5e64c..32c86ccf09 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1,4327 +1,4327 @@ -open GobConfig -open GoblintCil -open Pretty -open PrecisionUtil - -module M = Messages - -let (%) = Batteries.(%) -let (|?) = Batteries.(|?) - -exception IncompatibleIKinds of string -exception Unknown -exception Error -exception ArithmeticOnIntegerBot of string - - - -(* Custom Tuple6 as Batteries only provides up to Tuple5 *) -module Tuple6 = struct - type ('a,'b,'c,'d,'e,'f) t = 'a * 'b * 'c * 'd * 'e * 'f - - type 'a enumerable = 'a * 'a * 'a * 'a * 'a * 'a - - let make a b c d e f= (a, b, c, d, e, f) - - let first (a,_,_,_,_, _) = a - let second (_,b,_,_,_, _) = b - let third (_,_,c,_,_, _) = c - let fourth (_,_,_,d,_, _) = d - let fifth (_,_,_,_,e, _) = e - let sixth (_,_,_,_,_, f) = f - - let map f1 f2 f3 f4 f5 f6 (a,b,c,d,e,f) = - let a = f1 a in - let b = f2 b in - let c = f3 c in - let d = f4 d in - let e = f5 e in - let f = f6 f in - (a, b, c, d, e, f) - - let mapn fn (a,b,c,d,e,f) = - let a = fn a in - let b = fn b in - let c = fn c in - let d = fn d in - let e = fn e in - let f = fn f in - (a, b, c, d, e, f) - - let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) - let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) - let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) - let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) - let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) - let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) - - - - - let curry fn a b c d e f= fn (a,b,c,d,e,f) - let uncurry fn (a,b,c,d,e,f) = fn a b c d e f - - let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) - - let of_enum e = match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some a -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some b -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some c -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some d -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some e -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some f -> (a,b,c,d,e,f) - - let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e print_f out (a,b,c,d,e,f) = - BatIO.nwrite out first; - print_a out a; - BatIO.nwrite out sep; - print_b out b; - BatIO.nwrite out sep; - print_c out c; - BatIO.nwrite out sep; - print_d out d; - BatIO.nwrite out sep; - print_e out e; - BatIO.nwrite out sep; - print_f out f - BatIO.nwrite out last - - - let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = - print ~first ~sep ~last printer printer printer printer printer out pair - - let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) ?(cmp6=Pervasives.compare) (a1,a2,a3,a4,a5,a6) (b1,b2,b3,b4,b5,b6) = - let c1 = cmp1 a1 b1 in - if c1 <> 0 then c1 else - let c2 = cmp2 a2 b2 in - if c2 <> 0 then c2 else - let c3 = cmp3 a3 b3 in - if c3 <> 0 then c3 else - let c4 = cmp4 a4 b4 in - if c4 <> 0 then c4 else - let c5 = cmp5 a5 b5 in - if c5 <> 0 then c5 else - cmp5 a6 b6 - - open BatOrd - let eq eq1 eq2 eq3 eq4 eq5 eq6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_eq eq1 t1 t1' - (bin_eq eq2 t2 t2' - (bin_eq eq3 t3 t3' - (bin_eq eq4 t4 t4' - (bin_eq eq5 t5 t5' eq6)))) t6 t6' - - let ord ord1 ord2 ord3 ord4 ord5 ord6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_ord ord1 t1 t1' - (bin_ord ord2 t2 t2' - (bin_ord ord3 t3 t3' - (bin_ord ord4 t4 t4' - (bin_ord ord5 t5 t5' ord6)))) t6 t6' - - let comp comp1 comp2 comp3 comp4 comp5 comp6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - let c1 = comp1 t1 t1' in - if c1 <> 0 then c1 else - let c2 = comp2 t2 t2' in - if c2 <> 0 then c2 else - let c3 = comp3 t3 t3' in - if c3 <> 0 then c3 else - let c4 = comp4 t4 t4' in - if c4 <> 0 then c4 else - let c5 = comp5 t5 t5' in - if c5 <> 0 then c5 else - comp6 t6 t6' - - module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let eq = eq A.eq B.eq C.eq D.eq E.eq F.eq - end - - module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord ) (F : Ord) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let ord = ord A.ord B.ord C.ord D.ord E.ord F.ord - end - - module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp ) (F : Comp) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let compare = comp A.compare B.compare C.compare D.compare E.compare F.compare - end -end - - - -(** Define records that hold mutable variables representing different Configuration values. - * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) -type ana_int_config_values = { - mutable interval_threshold_widening : bool option; - mutable interval_narrow_by_meet : bool option; - mutable def_exc_widen_by_join : bool option; - mutable interval_threshold_widening_constants : string option; - mutable refinement : string option; -} - -let ana_int_config: ana_int_config_values = { - interval_threshold_widening = None; - interval_narrow_by_meet = None; - def_exc_widen_by_join = None; - interval_threshold_widening_constants = None; - refinement = None; -} - -let get_interval_threshold_widening () = - if ana_int_config.interval_threshold_widening = None then - ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); - Option.get ana_int_config.interval_threshold_widening - -let get_interval_narrow_by_meet () = - if ana_int_config.interval_narrow_by_meet = None then - ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); - Option.get ana_int_config.interval_narrow_by_meet - -let get_def_exc_widen_by_join () = - if ana_int_config.def_exc_widen_by_join = None then - ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); - Option.get ana_int_config.def_exc_widen_by_join - -let get_interval_threshold_widening_constants () = - if ana_int_config.interval_threshold_widening_constants = None then - ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); - Option.get ana_int_config.interval_threshold_widening_constants - -let get_refinement () = - if ana_int_config.refinement = None then - ana_int_config.refinement <- Some (get_string "ana.int.refinement"); - Option.get ana_int_config.refinement - - - -(** Whether for a given ikind, we should compute with wrap-around arithmetic. - * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) -let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" - -(** Whether for a given ikind, we should assume there are no overflows. - * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) -let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" - -let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds -let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) - -type overflow_info = { overflow: bool; underflow: bool;} - -let set_overflow_flag ~cast ~underflow ~overflow ik = - if !AnalysisState.executing_speculative_computations then - (* Do not produce warnings when the operations are not actually happening in code *) - () - else - let signed = Cil.isSigned ik in - if !AnalysisState.postsolving && signed && not cast then - AnalysisState.svcomp_may_overflow := true; - let sign = if signed then "Signed" else "Unsigned" in - match underflow, overflow with - | true, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign - | true, false -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign - | false, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign - | false, false -> assert false - -let reset_lazy () = - ResettableLazy.reset widening_thresholds; - ResettableLazy.reset widening_thresholds_desc; - ana_int_config.interval_threshold_widening <- None; - ana_int_config.interval_narrow_by_meet <- None; - ana_int_config.def_exc_widen_by_join <- None; - ana_int_config.interval_threshold_widening_constants <- None; - ana_int_config.refinement <- None - -module type Arith = -sig - type t - val neg: t -> t - val add: t -> t -> t - val sub: t -> t -> t - val mul: t -> t -> t - val div: t -> t -> t - val rem: t -> t -> t - - val lt: t -> t -> t - val gt: t -> t -> t - val le: t -> t -> t - val ge: t -> t -> t - val eq: t -> t -> t - val ne: t -> t -> t - - val lognot: t -> t - val logand: t -> t -> t - val logor : t -> t -> t - val logxor: t -> t -> t - - val shift_left : t -> t -> t - val shift_right: t -> t -> t - - val c_lognot: t -> t - val c_logand: t -> t -> t - val c_logor : t -> t -> t - -end - -module type ArithIkind = -sig - type t - val neg: Cil.ikind -> t -> t - val add: Cil.ikind -> t -> t -> t - val sub: Cil.ikind -> t -> t -> t - val mul: Cil.ikind -> t -> t -> t - val div: Cil.ikind -> t -> t -> t - val rem: Cil.ikind -> t -> t -> t - - val lt: Cil.ikind -> t -> t -> t - val gt: Cil.ikind -> t -> t -> t - val le: Cil.ikind -> t -> t -> t - val ge: Cil.ikind -> t -> t -> t - val eq: Cil.ikind -> t -> t -> t - val ne: Cil.ikind -> t -> t -> t - - val lognot: Cil.ikind -> t -> t - val logand: Cil.ikind -> t -> t -> t - val logor : Cil.ikind -> t -> t -> t - val logxor: Cil.ikind -> t -> t -> t - - val shift_left : Cil.ikind -> t -> t -> t - val shift_right: Cil.ikind -> t -> t -> t - - val c_lognot: Cil.ikind -> t -> t - val c_logand: Cil.ikind -> t -> t -> t - val c_logor : Cil.ikind -> t -> t -> t - -end - -(* Shared functions between S and Z *) -module type B = -sig - include Lattice.S - type int_t - val bot_of: Cil.ikind -> t - val top_of: Cil.ikind -> t - val to_int: t -> int_t option - val equal_to: int_t -> t -> [`Eq | `Neq | `Top] - - val to_bool: t -> bool option - val to_excl_list: t -> (int_t list * (int64 * int64)) option - val of_excl_list: Cil.ikind -> int_t list -> t - val is_excl_list: t -> bool - - val to_incl_list: t -> int_t list option - - val maximal : t -> int_t option - val minimal : t -> int_t option - - val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t -end - -(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) -module type IkindUnawareS = -sig - include B - include Arith with type t := t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: int_t -> t - val of_bool: bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val arbitrary: unit -> t QCheck.arbitrary - val invariant: Cil.exp -> t -> Invariant.t -end - -(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) -module type S = -sig - include B - include ArithIkind with type t:= t - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val neg : ?no_ov:bool -> Cil.ikind -> t -> t - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t - - val join: Cil.ikind -> t -> t -> t - val meet: Cil.ikind -> t -> t -> t - val narrow: Cil.ikind -> t -> t -> t - val widen: Cil.ikind -> t -> t -> t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val is_top_of: Cil.ikind -> t -> bool - val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t - - val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t - val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t - - val project: Cil.ikind -> int_precision -> t -> t - val arbitrary: Cil.ikind -> t QCheck.arbitrary -end - -module type SOverflow = -sig - - include S - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val of_int : Cil.ikind -> int_t -> t * overflow_info - - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - - val shift_left : Cil.ikind -> t -> t -> t * overflow_info - - val shift_right : Cil.ikind -> t -> t -> t * overflow_info -end - -module type Y = -sig - (* include B *) - include B - include Arith with type t:= t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val is_top_of: Cil.ikind -> t -> bool - - val project: int_precision -> t -> t - val invariant: Cil.exp -> t -> Invariant.t -end - -module type Z = Y with type int_t = Z.t - - -module IntDomLifter (I : S) = -struct - open Cil - type int_t = I.int_t - type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] - - let ikind {ikind; _} = ikind - - (* Helper functions *) - let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) - let lift op x = {x with v = op x.ikind x.v } - (* For logical operations the result is of type int *) - let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} - let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } - let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} - - let bot_of ikind = { v = I.bot_of ikind; ikind} - let bot () = failwith "bot () is not implemented for IntDomLifter." - let is_bot x = I.is_bot x.v - let top_of ikind = { v = I.top_of ikind; ikind} - let top () = failwith "top () is not implemented for IntDomLifter." - let is_top x = I.is_top x.v - - (* Leq does not check for ikind, because it is used in invariant with arguments of different type. - TODO: check ikinds here and fix invariant to work with right ikinds *) - let leq x y = I.leq x.v y.v - let join = lift2 I.join - let meet = lift2 I.meet - let widen = lift2 I.widen - let narrow = lift2 I.narrow - - let show x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - "⊤" - else - I.show x.v (* TODO add ikind to output *) - let pretty () x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - Pretty.text "⊤" - else - I.pretty () x.v (* TODO add ikind to output *) - let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) - let printXml o x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - BatPrintf.fprintf o "\n\n⊤\n\n\n" - else - I.printXml o x.v (* TODO add ikind to output *) - (* This is for debugging *) - let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" - let to_yojson x = I.to_yojson x.v - let invariant e x = - let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in - I.invariant_ikind e' x.ikind x.v - let tag x = I.tag x.v - let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." - let to_int x = I.to_int x.v - let of_int ikind x = { v = I.of_int ikind x; ikind} - let equal_to i x = I.equal_to i x.v - let to_bool x = I.to_bool x.v - let of_bool ikind b = { v = I.of_bool ikind b; ikind} - let to_excl_list x = I.to_excl_list x.v - let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} - let is_excl_list x = I.is_excl_list x.v - let to_incl_list x = I.to_incl_list x.v - let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} - let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} - let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} - let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} - let maximal x = I.maximal x.v - let minimal x = I.minimal x.v - - let neg = lift I.neg - let add = lift2 I.add - let sub = lift2 I.sub - let mul = lift2 I.mul - let div = lift2 I.div - let rem = lift2 I.rem - let lt = lift2_cmp I.lt - let gt = lift2_cmp I.gt - let le = lift2_cmp I.le - let ge = lift2_cmp I.ge - let eq = lift2_cmp I.eq - let ne = lift2_cmp I.ne - let lognot = lift I.lognot - let logand = lift2 I.logand - let logor = lift2 I.logor - let logxor = lift2 I.logxor - let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) - let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) - let c_lognot = lift_logical I.c_lognot - let c_logand = lift2 I.c_logand - let c_logor = lift2 I.c_logor - - let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} - - let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v - - let relift x = { v = I.relift x.v; ikind = x.ikind } - - let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } -end - -module type Ikind = -sig - val ikind: unit -> Cil.ikind -end - -module PtrDiffIkind : Ikind = -struct - let ikind = Cilfacade.ptrdiff_ikind -end - -module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = -struct - include I - let top () = I.top_of (Ik.ikind ()) - let bot () = I.bot_of (Ik.ikind ()) -end - -module Size = struct (* size in bits as int, range as int64 *) - open Cil - let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned - - let top_typ = TInt (ILongLong, []) - let min_for x = intKindForValue x (sign x = `Unsigned) - let bit = function (* bits needed for representation *) - | IBool -> 1 - | ik -> bytesSizeOfInt ik * 8 - let is_int64_big_int x = Z.fits_int64 x - let card ik = (* cardinality *) - let b = bit ik in - Z.shift_left Z.one b - let bits ik = (* highest bits for neg/pos values *) - let s = bit ik in - if isSigned ik then s-1, s-1 else 0, s - let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) - let range ik = - let a,b = bits ik in - let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in - let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) - x,y - - let is_cast_injective ~from_type ~to_type = - let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in - let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in - if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; - Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 - - let cast t x = (* TODO: overflow is implementation-dependent! *) - if t = IBool then - (* C11 6.3.1.2 Boolean type *) - if Z.equal x Z.zero then Z.zero else Z.one - else - let a,b = range t in - let c = card t in - let y = Z.erem x c in - let y = if Z.gt y b then Z.sub y c - else if Z.lt y a then Z.add y c - else y - in - if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); - y - - let min_range_sign_agnostic x = - let size ik = - let a,b = bits_i64 ik in - Int64.neg a,b - in - if sign x = `Signed then - size (min_for x) - else - let a, b = size (min_for x) in - if b <= 64L then - let upper_bound_less = Int64.sub b 1L in - let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in - if x <= max_one_less then - a, upper_bound_less - else - a,b - else - a, b - - (* From the number of bits used to represent a positive value, determines the maximal representable value *) - let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) - - (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) - let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) - -end - - -module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct - open B - (* these should be overwritten for better precision if possible: *) - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let starting ?(suppress_ovwarn=false) ik x = top_of ik - let ending ?(suppress_ovwarn=false) ik x = top_of ik - let maximal x = None - let minimal x = None -end - -module Std (B: sig - type t - val name: unit -> string - val top_of: Cil.ikind -> t - val bot_of: Cil.ikind -> t - val show: t -> string - val equal: t -> t -> bool - end) = struct - include Printable.StdLeaf - let name = B.name (* overwrite the one from Printable.Std *) - open B - let is_top x = failwith "is_top not implemented for IntDomain.Std" - let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind - This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) - let is_top_of ik x = B.equal x (top_of ik) - - (* all output is based on B.show *) - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) - let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y - - include StdTop (B) -end - -(* Textbook interval arithmetic, without any overflow handling etc. *) -module IntervalArith (Ints_t : IntOps.IntOps) = struct - let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) - let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) - - let mul (x1, x2) (y1, y2) = - let x1y1 = (Ints_t.mul x1 y1) in - let x1y2 = (Ints_t.mul x1 y2) in - let x2y1 = (Ints_t.mul x2 y1) in - let x2y2 = (Ints_t.mul x2 y2) in - (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) - - let shift_left (x1,x2) (y1,y2) = - let y1p = Ints_t.shift_left Ints_t.one y1 in - let y2p = Ints_t.shift_left Ints_t.one y2 in - mul (x1, x2) (y1p, y2p) - - let div (x1, x2) (y1, y2) = - let x1y1n = (Ints_t.div x1 y1) in - let x1y2n = (Ints_t.div x1 y2) in - let x2y1n = (Ints_t.div x2 y1) in - let x2y2n = (Ints_t.div x2 y2) in - let x1y1p = (Ints_t.div x1 y1) in - let x1y2p = (Ints_t.div x1 y2) in - let x2y1p = (Ints_t.div x2 y1) in - let x2y2p = (Ints_t.div x2 y2) in - (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) - - let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) - let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) - - let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) - - let one = (Ints_t.one, Ints_t.one) - let zero = (Ints_t.zero, Ints_t.zero) - let top_bool = (Ints_t.zero, Ints_t.one) - - let to_int (x1, x2) = - if Ints_t.equal x1 x2 then Some x1 else None - - let upper_threshold u max_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - let max_ik' = Ints_t.to_bigint max_ik in - let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in - BatOption.map_default Ints_t.of_bigint max_ik t - let lower_threshold l min_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - let min_ik' = Ints_t.to_bigint min_ik in - let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in - BatOption.map_default Ints_t.of_bigint min_ik t - let is_upper_threshold u = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - List.exists (Z.equal u) ts - let is_lower_threshold l = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - List.exists (Z.equal l) ts -end - -module IntInvariant = -struct - let of_int e ik x = - if get_bool "witness.invariant.exact" then - Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) - else - Invariant.none - - let of_incl_list e ik ps = - match ps with - | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> - assert (List.mem Z.zero ps); - assert (List.mem Z.one ps); - Invariant.none - | [_] when get_bool "witness.invariant.exact" -> - Invariant.none - | _ :: _ :: _ - | [_] | [] -> - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in - Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) (Invariant.bot ()) ps - - let of_interval_opt e ik = function - | (Some x1, Some x2) when Z.equal x1 x2 -> - of_int e ik x1 - | x1_opt, x2_opt -> - let (min_ik, max_ik) = Size.range ik in - let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in - let i1 = - match x1_opt, inexact_type_bounds with - | Some x1, false when Z.equal min_ik x1 -> Invariant.none - | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) - | None, _ -> Invariant.none - in - let i2 = - match x2_opt, inexact_type_bounds with - | Some x2, false when Z.equal x2 max_ik -> Invariant.none - | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) - | None, _ -> Invariant.none - in - Invariant.(i1 && i2) - - let of_interval e ik (x1, x2) = - of_interval_opt e ik (Some x1, Some x2) - - let of_excl_list e ik ns = - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in - Invariant.(a && i) - ) (Invariant.top ()) ns -end - -module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = -struct - let name () = "intervals" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - module IArith = IntervalArith (Ints_t) - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - let top_of ik = Some (range ik) - let bot () = None - let bot_of ik = bot () (* TODO: improve *) - - let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) -> - if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> - if Ints_t.compare x y > 0 then - (None,{underflow=false; overflow=false}) - else ( - let (min_ik, max_ik) = range ik in - let underflow = Ints_t.compare min_ik x > 0 in - let overflow = Ints_t.compare max_ik y < 0 in - let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in - let v = - if underflow || overflow then - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in - let resdiff = Ints_t.abs (Ints_t.sub y x) in - if Ints_t.compare resdiff diff > 0 then - top_of ik - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if Ints_t.compare l u <= 0 then - Some (l, u) - else - (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) - top_of ik - else if not cast && should_ignore_overflow ik then - let tl, tu = BatOption.get @@ top_of ik in - Some (Ints_t.max tl x, Ints_t.min tu y) - else - top_of ik - else - Some (x,y) - in - (v, ov_info) - ) - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst - - let meet ik (x:t) y = - match x, y with - | None, z | z, None -> None - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst - - (* TODO: change to_int signature so it returns a big_int *) - let to_int x = Option.bind x (IArith.to_int) - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) - let of_int ik (x: int_t) = of_interval ik (x,x) - let zero = Some IArith.zero - let one = Some IArith.one - let top_bool = Some IArith.top_bool - - let of_bool _ik = function true -> one | false -> zero - let to_bool (a: t) = match a with - | None -> None - | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) - - (* TODO: change signature of maximal, minimal to return big_int*) - let maximal = function None -> None | Some (x,y) -> Some y - let minimal = function None -> None | Some (x,y) -> Some x - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) - - let widen ik x y = - match x, y with - | None, z | z, None -> z - | Some (l0,u0), Some (l1,u1) -> - let (min_ik, max_ik) = range ik in - let threshold = get_interval_threshold_widening () in - let l2 = - if Ints_t.compare l0 l1 = 0 then l0 - else if threshold then IArith.lower_threshold l1 min_ik - else min_ik - in - let u2 = - if Ints_t.compare u0 u1 = 0 then u0 - else if threshold then IArith.upper_threshold u1 max_ik - else max_ik - in - norm ik @@ Some (l2,u2) |> fst - let widen ik x y = - let r = widen ik x y in - if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; - assert (leq x y); (* TODO: remove for performance reasons? *) - r - - let narrow ik x y = - match x, y with - | _,None | None, _ -> None - | Some (x1,x2), Some (y1,y2) -> - let threshold = get_interval_threshold_widening () in - let (min_ik, max_ik) = range ik in - let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in - let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in - norm ik @@ Some (lr,ur) |> fst - - - let narrow ik x y = - if get_interval_narrow_by_meet () then - meet ik x y - else - narrow ik x y - - let log f ~annihilator ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, _ when x = annihilator -> of_bool ik annihilator - | _, Some y when y = annihilator -> of_bool ik annihilator - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) ~annihilator:true - let c_logand = log (&&) ~annihilator:false - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let bit f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - let bitcomp f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let logxor = bit (fun _ik -> Ints_t.logxor) - - let logand ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) - | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst - | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst - | _ -> top_of ik - - let logor = bit (fun _ik -> Ints_t.logor) - - let bit1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_int i1 with - | Some x -> of_int ik (f ik x) |> fst - | _ -> top_of ik - - let lognot = bit1 (fun _ik -> Ints_t.lognot) - let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) - - let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) - - let binary_op_with_norm ?no_ov op ik x y = match x, y with - | None, None -> (None, {overflow=false; underflow= false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some x, Some y -> norm ik @@ Some (op x y) - - let add ?no_ov = binary_op_with_norm IArith.add - let mul ?no_ov = binary_op_with_norm IArith.mul - let sub ?no_ov = binary_op_with_norm IArith.sub - - let shift_left ik a b = - match is_bot a, is_bot b with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) - | _ -> - match a, minimal b, maximal b with - | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> - (try - let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in - norm ik @@ Some r - with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let rem ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (xl, xu), Some (yl, yu) -> - if is_top_of ik x && is_top_of ik y then - (* This is needed to preserve soundness also on things bigger than int32 e.g. *) - (* x: 3803957176L -> T in Interval32 *) - (* y: 4209861404L -> T in Interval32 *) - (* x % y: 3803957176L -> T in Interval32 *) - (* T in Interval32 is [-2147483648,2147483647] *) - (* the code below computes [-2147483647,2147483647] for this though which is unsound *) - top_of ik - else - (* If we have definite values, Ints_t.rem will give a definite result. - * Otherwise we meet with a [range] the result can be in. - * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. - * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) - let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in - let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in - let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range - - let rec div ?no_ov ik x y = - match x, y with - | None, None -> (bot (),{underflow=false; overflow=false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | (Some (x1,x2) as x), (Some (y1,y2) as y) -> - begin - let is_zero v = Ints_t.compare v Ints_t.zero = 0 in - match y1, y2 with - | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) - | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) - | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) - | _ -> binary_op_with_norm IArith.div ik x y - end - - let ne ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik true - else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then - of_bool ik false - else top_bool - - let eq ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then - of_bool ik true - else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik false - else top_bool - - let ge ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 then of_bool ik true - else if Ints_t.compare x2 y1 < 0 then of_bool ik false - else top_bool - - let le ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 <= 0 then of_bool ik true - else if Ints_t.compare y2 x1 < 0 then of_bool ik false - else top_bool - - let gt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 then of_bool ik true - else if Ints_t.compare x2 y1 <= 0 then of_bool ik false - else top_bool - - let lt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 < 0 then of_bool ik true - else if Ints_t.compare y2 x1 <= 0 then of_bool ik false - else top_bool - - let invariant_ikind e ik = function - | Some (x1, x2) -> - let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in - IntInvariant.of_interval e ik (x1', x2') - | None -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink = function - | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) - | None -> empty - in - QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) - - let modulo n k = - let result = Ints_t.rem n k in - if Ints_t.compare result Ints_t.zero >= 0 then result - else Ints_t.add result k - - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None - else if Ints_t.equal m Ints_t.zero then - Some (c, c) - else - let (min_ik, max_ik) = range ik in - let rcx = - if Ints_t.equal x min_ik then x else - Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in - let lcy = - if Ints_t.equal y max_ik then y else - Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in - if Ints_t.compare rcx lcy > 0 then None - else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst - else norm ik @@ Some (rcx, lcy) |> fst - | _ -> None - - let refine_with_congruence ik x y = - let refn = refine_with_congruence ik x y in - if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; - refn - - let refine_with_interval ik a b = meet ik a b - - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - match intv, excl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls, (rl, rh)) -> - let rec shrink op b = - let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in - if not (Ints_t.equal b new_b) then shrink op new_b else new_b - in - let (min_ik, max_ik) = range ik in - let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in - let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in - let intv' = norm ik @@ Some (l', u') |> fst in - let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in - meet ik intv' range - - let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = - match intv, incl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls) -> - let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in - let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in - match min None ls, max None ls with - | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) - | _, _-> intv - - let project ik p t = t -end - -module BitFieldArith (Ints_t : IntOps.IntOps) = struct - let zero_mask = Ints_t.zero - let one_mask = Ints_t.lognot zero_mask - - let of_int x = (Ints_t.lognot x, x) - let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - - let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) - - let is_constant (z,o) = (Ints_t.logxor z o) = one_mask - - let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) - - let nabla x y= if x = Ints_t.logor x y then x else one_mask - - let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) - - let lognot (z,o) = (o,z) - - let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), - Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) - - let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) - - let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) - - let min ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - let max ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - - if isSigned ik then - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - - let one = of_int Ints_t.one - let zero = of_int Ints_t.zero - let top_bool = join one zero - -end - -module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct - let name () = "bitfield" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] - - module BArith = BitFieldArith (Ints_t) - - let top () = (BArith.one_mask, BArith.one_mask) - let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = top () - let bot_of ik = bot () - - let range ik bf = (BArith.min ik bf, BArith.max ik bf) - - let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) - - let norm ?(suppress_ovwarn=false) ik (z,o) = - let (min_ik, max_ik) = Size.range ik in - - let (min,max) = range ik (z,o) in - let underflow = Z.compare min min_ik < 0 in - let overflow = Z.compare max max_ik > 0 in - - let new_bitfield= - (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in - (newz,newo) - else - let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in - (newz,newo)) - in - if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) - else (new_bitfield, {underflow=underflow; overflow=overflow}) - - let show t = - if t = bot () then "bot" else - if t = top () then "top" else - let (z,o) = t in - if BArith.is_constant t then - Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) - else - Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst - - let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst - - let leq (x:t) (y:t) = (BArith.join x y) = y - - let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = y - - let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) - - let to_int (z,o) = if is_bot (z,o) then None else - if BArith.is_constant (z,o) then Some o - else None - - let equal_to i bf = - if BArith.of_int i = bf then `Eq - else if leq (BArith.of_int i) bf then `Top - else `Neq - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - (* naive implentation -> horrible O(n) runtime *) - let (min_ik, max_ik) = Size.range ik in - let result = ref (bot ()) in - let current = ref (min_ik) in - let bf = ref (bot ()) in - while Z.leq !current max_ik do - bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); - current := Z.add !current Z.one - done; - norm ~suppress_ovwarn ik !result - - let of_bool _ik = function true -> BArith.one | false -> BArith.zero - - let to_bool d = - if not (leq BArith.zero d) then Some true - else if BArith.eq d BArith.zero then Some false - else None - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t - - - (* Logic *) - - let log1 f ik i1 = match to_bool i1 with - | None -> top_of ik - | Some x -> of_bool ik (f x) - - let log2 f ik i1 i2 = match (to_bool i1, to_bool i2) with - | None, None -> top_of ik - | None, Some x | Some x, None -> of_bool ik x - | Some x, Some y -> of_bool ik (f x y) - let c_logor ik i1 i2 = log2 (||) ik i1 i2 - - let c_logand ik i1 i2 = log2 (&&) ik i1 i2 - - let c_lognot ik i1 = log1 not ik i1 - - - (* Bitwise *) - - let logxor ik i1 i2 = BArith.logxor i1 i2 - - let logand ik i1 i2 = BArith.logand i1 i2 - - let logor ik i1 i2 = BArith.logor i1 i2 - - let lognot ik i1 = BArith.lognot i1 - - let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) - - let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) - - - (* Arith *) - - (* - add, sub and mul based on the paper - "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" - of Vishwanathan et al. - *) - - let add ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in - let sv = Ints_t.add pv qv in - let sm = Ints_t.add pm qm in - let sigma = Ints_t.add sv sm in - let chi = Ints_t.logxor sigma sv in - let mu = Ints_t.logor (Ints_t.logor pm qm) chi in - let rv = Ints_t.logand sv (Ints_t.lognot mu) in - let rm = mu in - let o3 = Ints_t.logor rv rm in - let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) - - let sub ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in - let dv = Ints_t.sub pv qv in - let alpha = Ints_t.add dv pm in - let beta = Ints_t.sub dv qm in - let chi = Ints_t.logxor alpha beta in - let mu = Ints_t.logor (Ints_t.logor pm qm) chi in - let rv = Ints_t.logand dv (Ints_t.lognot mu) in - let rm = mu in - let o3 = Ints_t.logor rv rm in - let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) - - let neg ?no_ov ik x = - M.trace "bitfield" "neg"; - sub ?no_ov ik BArith.zero x - - let mul ?no_ov ik (z1, o1) (z2, o2) = - let z1 = ref z1 in - let o1 = ref o1 in - let z2 = ref z2 in - let o2 = ref o2 in - let z3 = ref BArith.one_mask in - let o3 = ref BArith.zero_mask in - for i = Size.bit ik downto 0 do - if Ints_t.logand !o1 Ints_t.one == Ints_t.one then - if Ints_t.logand !z1 Ints_t.one == Ints_t.one then - let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in - z3 := Ints_t.logor !z3 tmp; - o3 := Ints_t.logor !o3 tmp - else - let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in - z3 := fst tmp; - o3 := snd tmp - ; - z1 := Ints_t.shift_right !z1 1; - o1 := Ints_t.shift_right !o1 1; - z2 := Ints_t.shift_left !z2 1; - o2 := Ints_t.shift_left !o2 1; - done; - ((!z3, !o3),{underflow=false; overflow=false}) - - let rec div ?no_ov ik (z1, o1) (z2, o2) = - if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) - else (top_of ik,{underflow=false; overflow=false}) - - let rem ik x y = - M.trace "bitfield" "rem"; - if BArith.is_constant x && BArith.is_constant y then ( - (* x % y = x - (x / y) * y *) - let tmp = fst (div ik x y) in - let tmp = fst (mul ik tmp y) in - fst (sub ik x tmp)) - else top_of ik - - let eq ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) - else if not (leq x y || leq y x) then of_bool ik false - else BArith.top_bool - - let ne ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) - else if not (leq x y || leq y x) then of_bool ik true - else BArith.top_bool - - let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true - else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false - else BArith.top_bool - - let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true - else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false - else BArith.top_bool - - let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true - else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false - else BArith.top_bool - - let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true - else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false - else BArith.top_bool - - - let invariant_ikind e ik (z,o) = - let range = range ik (z,o) in - IntInvariant.of_interval e ik range - - let starting ?(suppress_ovwarn=false) ik n = - if Ints_t.compare n Ints_t.zero >= 0 then - (* sign bit can only be 0, as all numbers will be positive *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let zs = BArith.one_mask in - let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) - - let ending ?(suppress_ovwarn=false) ik n = - if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then - (* sign bit can only be 1, as all numbers will be negative *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in - let os = BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) - - let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in - match intv, cong with - | (z,o), Some (c, m) -> - if is_power_of_two m then - let congruenceMask = Ints_t.lognot m in - let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in - let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - (newz, newo) - else - top_of ik - | _ -> top_of ik - - let refine_with_interval ik t i = t - - let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t - - let invariant_ikind e ik = - M.trace "bitfield" "invariant_ikind"; - failwith "Not implemented" - - let refine_with_congruence ik bf (cong : (int_t * int_t ) option) : t = - M.trace "bitfield" "refine_with_congruence"; - bf - - let refine_with_interval ik bf (intv : (int_t * int_t) option) : t = - M.trace "bitfield" "refine_with_interval"; - bf - - let refine_with_excl_list ik bf (excl : (int_t list * (int64 * int64)) option) : t = - M.trace "bitfield" "refine_with_excl_list"; - bf - - let refine_with_incl_list ik t (incl : (int_t list) option) : t = - (* loop over all included ints *) - let incl_list_masks = match incl with - | None -> t - | Some ls -> - List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls - in - BArith.meet t incl_list_masks - - let arbitrary ik = - let open QCheck.Iter in - let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb1 int_arb2 in - let shrink = function - | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) - in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) - - let project ik p t = t -end - - -(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) -module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = -struct - - module Interval = IntervalFunctor (Ints_t) - module IArith = IntervalArith (Ints_t) - - - let name () = "interval_sets" - - type int_t = Ints_t.t - - let (>.) a b = Ints_t.compare a b > 0 - let (=.) a b = Ints_t.compare a b = 0 - let (<.) a b = Ints_t.compare a b < 0 - let (>=.) a b = Ints_t.compare a b >= 0 - let (<=.) a b = Ints_t.compare a b <= 0 - let (+.) a b = Ints_t.add a b - let (-.) a b = Ints_t.sub a b - - (* - Each domain's element is guaranteed to be in canonical form. That is, each interval contained - inside the set does not overlap with each other and they are not adjacent. - *) - type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - - let top_of ik = [range ik] - - let bot () = [] - - let bot_of ik = bot () - - let show (x: t) = - let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in - List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" - - (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) - type event = Enter of Ints_t.t | Exit of Ints_t.t - - let unbox_event = function Enter x -> x | Exit x -> x - - let cmp_events x y = - (* Deliberately comparing ints first => Cannot be derived *) - let res = Ints_t.compare (unbox_event x) (unbox_event y) in - if res <> 0 then res - else - begin - match (x, y) with - | (Enter _, Exit _) -> -1 - | (Exit _, Enter _) -> 1 - | (_, _) -> 0 - end - - let interval_set_to_events (xs: t) = - List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs - - let two_interval_sets_to_events (xs: t) (ys: t) = - let xs = interval_set_to_events xs in - let ys = interval_set_to_events ys in - List.merge cmp_events xs ys - - (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap - This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) - let combined_event_list lattice_op (xs:event list) = - let l = match lattice_op with `Join -> 1 | `Meet -> 2 in - let aux (interval_count, acc) = function - | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) - | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) - in - List.fold_left aux (0, []) xs |> snd |> List.rev - - let rec events_to_intervals = function - | [] -> [] - | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) - | _ -> failwith "Invalid events list" - - let remove_empty_gaps (xs: t) = - let aux acc (l, r) = match acc with - | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' - | _ -> (l, r)::acc - in - List.fold_left aux [] xs |> List.rev - - let canonize (xs: t) = - interval_set_to_events xs |> - List.sort cmp_events |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let unop (x: t) op = match x with - | [] -> [] - | _ -> canonize @@ List.concat_map op x - - let binop (x: t) (y: t) op : t = match x, y with - | [], _ -> [] - | _, [] -> [] - | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) - - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let minimal = function - | [] -> None - | (x, _)::_ -> Some x - - let maximal = function - | [] -> None - | xs -> Some (BatList.last xs |> snd) - - let equal_to_interval i (a, b) = - if a =. b && b =. i then - `Eq - else if a <=. i && i <=. b then - `Top - else - `Neq - - let equal_to i xs = match List.map (equal_to_interval i) xs with - | [] -> failwith "unsupported: equal_to with bottom" - | [`Eq] -> `Eq - | ys when List.for_all ((=) `Neq) ys -> `Neq - | _ -> `Top - - let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = - if x >. y then - ([],{underflow=false; overflow=false}) - else - let (min_ik, max_ik) = range ik in - let underflow = min_ik >. x in - let overflow = max_ik <. y in - let v = if underflow || overflow then - begin - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (max_ik -. min_ik) in - let resdiff = Ints_t.abs (y -. x) in - if resdiff >. diff then - [range ik] - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if l <=. u then - [(l, u)] - else - (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) - [(min_ik, u); (l, max_ik)] - else if not cast && should_ignore_overflow ik then - [Ints_t.max min_ik x, Ints_t.min max_ik y] - else - [range ik] - end - else - [(x,y)] - in - if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) - - let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = - let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) - - let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> - let res = List.map op (BatList.cartesian_product x y) in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let unary_op_with_norm op (ik:ikind) (x: t) = match x with - | [] -> ([],{overflow=false; underflow=false}) - | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x - - let rec leq (xs: t) (ys: t) = - let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in - match xs, ys with - | [], _ -> true - | _, [] -> false - | (xl,xr)::xs', (yl,yr)::ys' -> - if leq_interval (xl,xr) (yl,yr) then - leq xs' ys - else if xr <. yl then - false - else - leq xs ys' - - let join ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let meet ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Meet |> - events_to_intervals - - let to_int = function - | [x] -> IArith.to_int x - | _ -> None - - let zero = [IArith.zero] - let one = [IArith.one] - let top_bool = [IArith.top_bool] - - let not_bool (x:t) = - let is_false x = equal x zero in - let is_true x = equal x one in - if is_true x then zero else if is_false x then one else top_bool - - let to_bool = function - | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false - | x -> if leq zero x then None else Some true - - let of_bool _ = function true -> one | false -> zero - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) - - let of_int ik (x: int_t) = of_interval ik (x, x) - - let lt ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <. min_y then - of_bool ik true - else if min_x >=. max_y then - of_bool ik false - else - top_bool - - let le ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <=. min_y then - of_bool ik true - else if min_x >. max_y then - of_bool ik false - else - top_bool - - let gt ik x y = not_bool @@ le ik x y - - let ge ik x y = not_bool @@ lt ik x y - - let eq ik x y = match x, y with - | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> - one - | _ -> - if is_bot (meet ik x y) then - zero - else - top_bool - - let ne ik x y = not_bool @@ eq ik x y - let interval_to_int i = Interval.to_int (Some i) - let interval_to_bool i = Interval.to_bool (Some i) - - let log f ik (i1, i2) = - match (interval_to_bool i1, interval_to_bool i2) with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - - let bit f ik (i1, i2) = - match (interval_to_int i1), (interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - - let bitcomp f ik (i1, i2) = - match (interval_to_int i1, interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) - | _, _ -> (top_of ik,{overflow=false; underflow=false}) - - let logand ik x y = - let interval_logand = bit Ints_t.logand ik in - binop x y interval_logand - - let logor ik x y = - let interval_logor = bit Ints_t.logor ik in - binop x y interval_logor - - let logxor ik x y = - let interval_logxor = bit Ints_t.logxor ik in - binop x y interval_logxor - - let lognot ik x = - let interval_lognot i = - match interval_to_int i with - | Some x -> of_int ik (Ints_t.lognot x) |> fst - | _ -> top_of ik - in - unop x interval_lognot - - let shift_left ik x y = - let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftleft - - let shift_right ik x y = - let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftright - - let c_lognot ik x = - let log1 f ik i1 = - match interval_to_bool i1 with - | Some x -> of_bool ik (f x) - | _ -> top_of ik - in - let interval_lognot = log1 not ik in - unop x interval_lognot - - let c_logand ik x y = - let interval_logand = log (&&) ik in - binop x y interval_logand - - let c_logor ik x y = - let interval_logor = log (||) ik in - binop x y interval_logor - - let add ?no_ov = binary_op_with_norm IArith.add - let sub ?no_ov = binary_op_with_norm IArith.sub - let mul ?no_ov = binary_op_with_norm IArith.mul - let neg ?no_ov = unary_op_with_norm IArith.neg - - let div ?no_ov ik x y = - let rec interval_div x (y1, y2) = begin - let top_of ik = top_of ik |> List.hd in - let is_zero v = v =. Ints_t.zero in - match y1, y2 with - | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) - | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) - | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik - | _ -> IArith.div x (y1, y2) - end - in binary_op_with_norm interval_div ik x y - - let rem ik x y = - let interval_rem (x, y) = - if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then - top_of ik - else - let (xl, xu) = x in let (yl, yu) = y in - let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in - let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in - let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit Ints_t.rem ik (x, y)) [range] - in - binop x y interval_rem - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x - - (* - narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys - *) - let narrow ik xs ys = match xs ,ys with - | [], _ -> [] | _ ,[] -> xs - | _, _ -> - let min_xs = minimal xs |> Option.get in - let max_xs = maximal xs |> Option.get in - let min_ys = minimal ys |> Option.get in - let max_ys = maximal ys |> Option.get in - let min_range,max_range = range ik in - let threshold = get_interval_threshold_widening () in - let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in - let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in - xs - |> (function (_, y)::z -> (min, y)::z | _ -> []) - |> List.rev - |> (function (x, _)::z -> (x, max)::z | _ -> []) - |> List.rev - - (* - 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. - and joins all intervals in xs assigned to the same interval in ys as one interval. - 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. - 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) - - The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. - *) - let widen ik xs ys = - let (min_ik,max_ik) = range ik in - let threshold = get_bool "ana.int.interval_threshold_widening" in - let upper_threshold (_,u) = IArith.upper_threshold u max_ik in - let lower_threshold (l,_) = IArith.lower_threshold l min_ik in - (*obtain partitioning of xs intervals according to the ys interval that includes them*) - let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= - match xs,ys with - | _, [] -> [] - | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys - | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) - | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys - in - let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in - (*merge a pair of adjacent partitions*) - let merge_pair ik (a,b) (c,d) = - let new_a = function - | None -> Some (upper_threshold b, upper_threshold b) - | Some (ax,ay) -> Some (ax, upper_threshold b) - in - let new_c = function - | None -> Some (lower_threshold d, lower_threshold d) - | Some (cx,cy) -> Some (lower_threshold d, cy) - in - if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then - [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] - else - [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] - in - let partitions_are_approaching part_left part_right = match part_left, part_right with - | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) - | _,_ -> false - in - (*merge all approaching pairs of adjacent partitions*) - let rec merge_list ik = function - | [] -> [] - | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) - | x::xs -> x :: merge_list ik xs - in - (*expands left extremity*) - let widen_left = function - | [] -> [] - | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts - | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts - | x -> x - in - (*expands right extremity*) - let widen_right x = - let map_rightmost = function - | [] -> [] - | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts - | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts - | x -> x - in - List.rev x |> map_rightmost |> List.rev - in - interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd - - let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) - - let invariant_ikind e ik xs = - List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> - let open Invariant in List.fold_left (||) (bot ()) - - let modulo n k = - let result = Ints_t.rem n k in - if result >=. Ints_t.zero then result - else result +. k - - let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = - let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =. Ints_t.zero && (c <. x || c >. y) then [] - else if m =. Ints_t.zero then - [(c, c)] - else - let (min_ik, max_ik) = range ik in - let rcx = - if x =. min_ik then x else - x +. (modulo (c -. x) (Ints_t.abs m)) in - let lcy = - if y =. max_ik then y else - y -. (modulo (y -. c) (Ints_t.abs m)) in - if rcx >. lcy then [] - else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst - else norm_interval ik (rcx, lcy) |> fst - | _ -> [] - in - List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs - - let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] - - let refine_with_incl_list ik intvs = function - | None -> intvs - | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) - - let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = - let intv1 = (min, excl -. Ints_t.one) in - let intv2 = (excl +. Ints_t.one, max) in - norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst - - let of_excl_list ik (excls: int_t list) = - let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in - let res = List.fold_left (meet ik) (top_of ik) excl_list in - res - - let refine_with_excl_list ik (intv : t) = function - | None -> intv - | Some (xs, range) -> - let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = - excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl - in - let excl_list = List.map (excl_to_intervalset ik range) xs in - List.fold_left (meet ik) intv excl_list - - let project ik p t = t - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let list_pair_arb = QCheck.small_list pair_arb in - let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in - let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list - in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) -end - -module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct - include D - - let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = fst @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = fst @@ D.shift_left ik x y - - let shift_right ik x y = fst @@ D.shift_right ik x y -end - -module IntIkind = struct let ikind () = Cil.IInt end -module Interval = IntervalFunctor (IntOps.BigIntOps) -module Bitfield = BitfieldFunctor (IntOps.BigIntOps) -module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) -module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) -module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) -struct - include Printable.Std - let name () = "integers" - type t = Ints_t.t [@@deriving eq, ord, hash] - type int_t = Ints_t.t - let top () = raise Unknown - let bot () = raise Error - let top_of ik = top () - let bot_of ik = bot () - let show (x: Ints_t.t) = Ints_t.to_string x - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) - let is_top _ = false - let is_bot _ = false - - let equal_to i x = if i > x then `Neq else `Top - let leq x y = x <= y - let join x y = if Ints_t.compare x y > 0 then x else y - let widen = join - let meet x y = if Ints_t.compare x y > 0 then y else x - let narrow = meet - - let of_bool x = if x then Ints_t.one else Ints_t.zero - let to_bool' x = x <> Ints_t.zero - let to_bool x = Some (to_bool' x) - let of_int x = x - let to_int x = Some x - - let neg = Ints_t.neg - let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) - let sub = Ints_t.sub - let mul = Ints_t.mul - let div = Ints_t.div - let rem = Ints_t.rem - let lt n1 n2 = of_bool (n1 < n2) - let gt n1 n2 = of_bool (n1 > n2) - let le n1 n2 = of_bool (n1 <= n2) - let ge n1 n2 = of_bool (n1 >= n2) - let eq n1 n2 = of_bool (n1 = n2) - let ne n1 n2 = of_bool (n1 <> n2) - let lognot = Ints_t.lognot - let logand = Ints_t.logand - let logor = Ints_t.logor - let logxor = Ints_t.logxor - let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) - let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) - let c_lognot n1 = of_bool (not (to_bool' n1)) - let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) - let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) - let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." - let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) - let invariant _ _ = Invariant.none (* TODO *) -end - -module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) -struct - include Integers(IntOps.Int64Ops) - let top () = raise Unknown - let bot () = raise Error - let leq = equal - let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y - let join x y = if equal x y then x else top () - let meet x y = if equal x y then x else bot () -end - -module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) -struct - type int_t = Base.int_t - include Lattice.FlatConf (struct - include Printable.DefaultConf - let top_name = "Unknown int" - let bot_name = "Error int" - end) (Base) - - let top_of ik = top () - let bot_of ik = bot () - - - let name () = "flat integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let starting ?(suppress_ovwarn=false) ikind x = top_of ikind - let ending ?(suppress_ovwarn=false) ikind x = top_of ikind - let maximal x = None - let minimal x = None - - let lift1 f x = match x with - | `Lifted x -> - (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> - (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) -struct - include Lattice.LiftPO (struct - include Printable.DefaultConf - let top_name = "MaxInt" - let bot_name = "MinInt" - end) (Base) - type int_t = Base.int_t - let top_of ik = top () - let bot_of ik = bot () - include StdTop (struct type nonrec t = t let top_of = top_of end) - - let name () = "lifted integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let lift1 f x = match x with - | `Lifted x -> `Lifted (f x) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> `Lifted (f x y) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Flattened = Flat (Integers (IntOps.Int64Ops)) -module Lifted = Lift (Integers (IntOps.Int64Ops)) - -module Reverse (Base: IkindUnawareS) = -struct - include Base - include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) -end - -module BISet = struct - include SetDomain.Make (IntOps.BigIntOps) - let is_singleton s = cardinal s = 1 -end - -(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) -module Exclusion = -struct - module R = Interval32 - (* We use these types for the functions in this module to make the intended meaning more explicit *) - type t = Exc of BISet.t * Interval32.t - type inc = Inc of BISet.t [@@unboxed] - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) - - let cardinality_BISet s = - Z.of_int (BISet.cardinal s) - - let leq_excl_incl (Exc (xs, r)) (Inc ys) = - (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) - let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in - let card_b = cardinality_BISet ys in - if Z.compare lower_bound_cardinality_a card_b > 0 then - false - else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) - let min_a = min_of_range r in - let max_a = max_of_range r in - GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) - - let leq (Exc (xs, r)) (Exc (ys, s)) = - let min_a, max_a = min_of_range r, max_of_range r in - let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) - if not excluded_check - then false - else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) - if R.leq r s then true - else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) - then - let min_b, max_b = min_of_range s, max_of_range s in - let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) - if Z.compare min_a min_b < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) - else - true - in - let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) - if Z.compare max_b max_a < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) - else - true - in - leq1 && (leq2 ()) - else - false - end - end -end - -module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) -struct - module S = BISet - module R = Interval32 (* range for exclusion *) - - (* Ikind used for intervals representing the domain *) - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - - type t = [ - | `Excluded of S.t * R.t - | `Definite of Z.t - | `Bot - ] [@@deriving eq, ord, hash] - type int_t = Z.t - let name () = "def_exc" - - - let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) - let top () = `Excluded (S.empty (), top_range) - let bot () = `Bot - let top_of ik = `Excluded (S.empty (), size ik) - let bot_of ik = bot () - - let show x = - let short_size x = "("^R.show x^")" in - match x with - | `Bot -> "Error int" - | `Definite x -> Z.to_string x - (* Print the empty exclusion as if it was a distinct top element: *) - | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l - (* Prepend the exclusion sets with something: *) - | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let maximal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.max_of_range r) - | `Bot -> None - - let minimal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.min_of_range r) - | `Bot -> None - - let in_range r i = - if Z.compare i Z.zero < 0 then - let lowerb = Exclusion.min_of_range r in - Z.compare lowerb i <= 0 - else - let upperb = Exclusion.max_of_range r in - Z.compare i upperb <= 0 - - let is_top x = x = top () - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Definite x -> if i = x then `Eq else `Neq - | `Excluded (s,r) -> if S.mem i s then `Neq else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function - | `Excluded (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - `Excluded (s, r) - else if ik = IBool then (* downcast to bool *) - if S.mem Z.zero s then - `Definite Z.one - else - `Excluded (S.empty(), r') - else - (* downcast: may overflow *) - (* let s' = S.map (Size.cast ik) s in *) - (* We want to filter out all i in s' where (t)x with x in r could be i. *) - (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) - (* S.diff s' s, r' *) - (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) - `Excluded (S.empty (), r') - | `Definite x -> `Definite (Size.cast ik x) - | `Bot -> `Bot - - (* Wraps definite values and excluded values according to the ikind. - * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. - * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. - *) - let norm ik v = - match v with - | `Excluded (s, r) -> - let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in - (* If no overflow occurred, just return x *) - if not possibly_overflowed then ( - v - ) - (* Else, if an overflow might have occurred but we should just ignore it *) - else if should_ignore_overflow ik then ( - let r = size ik in - (* filter out excluded elements that are not in the range *) - let mapped_excl = S.filter (in_range r) s in - `Excluded (mapped_excl, r) - ) - (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) - else if not (should_wrap ik) then ( - top_of ik - ) else ( - (* Else an overflow occurred that we should treat with wrap-around *) - let r = size ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in - match ik with - | IBool -> - begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with - | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) - | true, false -> `Definite Z.one (* Not {0} -> 1 *) - | false, true -> `Definite Z.zero (* Not {1} -> 0 *) - | true, true -> `Bot (* Not {0, 1} -> bot *) - end - | ik -> - `Excluded (mapped_excl, r) - ) - | `Definite x -> - let min, max = Size.range ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - if should_wrap ik then ( - cast_to ik v - ) - else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( - v - ) - else if should_ignore_overflow ik then ( - M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; - `Bot - ) - else ( - top_of ik - ) - | `Bot -> `Bot - - let leq x y = match (x,y) with - (* `Bot <= x is always true *) - | `Bot, _ -> true - (* Anything except bot <= bot is always false *) - | _, `Bot -> false - (* Two known values are leq whenever equal *) - | `Definite (x: int_t), `Definite y -> x = y - (* A definite value is leq all exclusion sets that don't contain it *) - | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) - (* No finite exclusion set can be leq than a definite value *) - | `Excluded (xs, xr), `Definite d -> - Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) - | `Excluded (xs,xr), `Excluded (ys,yr) -> - Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) - - let join' ?range ik x y = - match (x,y) with - (* The least upper bound with the bottom element: *) - | `Bot, x -> x - | x, `Bot -> x - (* The case for two known values: *) - | `Definite (x: int_t), `Definite y -> - (* If they're equal, it's just THAT value *) - if x = y then `Definite x - (* Unless one of them is zero, we can exclude it: *) - else - let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in - `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) - (* A known value and an exclusion set... the definite value should no - * longer be excluded: *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> - if not (in_range r x) then - let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in - `Excluded (S.remove x s, R.join a r) - else - `Excluded (S.remove x s, r) - (* For two exclusion sets, only their intersection can be excluded: *) - | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) - - let join ik = join' ik - - - let widen ik x y = - if get_def_exc_widen_by_join () then - join' ik x y - else if equal x y then - x - else - join' ~range:(size ik) ik x y - - - let meet ik x y = - match (x,y) with - (* Greatest LOWER bound with the least element is trivial: *) - | `Bot, _ -> `Bot - | _, `Bot -> `Bot - (* Definite elements are either equal or the glb is bottom *) - | `Definite x, `Definite y -> if x = y then `Definite x else `Bot - (* The glb of a definite element and an exclusion set is either bottom or - * just the element itself, if it isn't in the exclusion set *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x - (* The greatest lower bound of two exclusion sets is their union, this is - * just DeMorgans Law *) - | `Excluded (x,r1), `Excluded (y,r2) -> - let r' = R.meet r1 r2 in - let s' = S.union x y |> S.filter (in_range r') in - `Excluded (s', r') - - let narrow ik x y = x - - let of_int ik x = norm ik @@ `Definite x - let to_int x = match x with - | `Definite x -> Some x - | _ -> None - - let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) - - let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) - let of_bool = of_bool_cmp - let to_bool x = - match x with - | `Definite x -> Some (IntOps.BigIntOps.to_bool x) - | `Excluded (s,r) when S.mem Z.zero s -> Some true - | _ -> None - let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in - norm ik @@ (`Excluded (ex, r)) - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let of_excl_list t l = - let r = size t in (* elements in l are excluded from the full range of t! *) - `Excluded (List.fold_right S.add l (S.empty ()), r) - let is_excl_list l = match l with `Excluded _ -> true | _ -> false - let to_excl_list (x:t) = match x with - | `Definite _ -> None - | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) - | `Bot -> None - - let to_incl_list x = match x with - | `Definite x -> Some [x] - | `Excluded _ -> None - | `Bot -> None - - let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) - (* If the Int64 might overflow on us during computation, we instead go to top_range *) - match R.minimal r, R.maximal r with - | _ -> - let rf m = (size % Size.min_for % f) (m r) in - let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in - R.join r1 r2 - - (* Default behaviour for unary operators, simply maps the function to the - * DefExc data structure. *) - let lift1 f ik x = norm ik @@ match x with - | `Excluded (s,r) -> - let s' = S.map f s in - `Excluded (s', apply_range f r) - | `Definite x -> `Definite (f x) - | `Bot -> `Bot - - let lift2 f ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite _ - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (f x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - (* Default behaviour for binary operators that are injective in either - * argument, so that Exclusion Sets can be used: *) - let lift2_inj f ik x y = - let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in - norm ik @@ - match x,y with - (* If both are exclusion sets, there isn't anything we can do: *) - | `Excluded _, `Excluded _ -> top () - (* A definite value should be applied to all members of the exclusion set *) - | `Definite x, `Excluded (s,r) -> def_exc f x s r - (* Same thing here, but we should flip the operator to map it properly *) - | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r - (* The good case: *) - | `Definite x, `Definite y -> `Definite (f x y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The equality check: *) - let eq ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x equal to an exclusion set, if it is a member then NO otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x = y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The inequality check: *) - let ne ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x <> y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x - let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y - - let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y - let mul ?no_ov ik x y = norm ik @@ match x, y with - | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x - | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y - | `Definite a, `Excluded (s,r) - (* Integer multiplication with even numbers is not injective. *) - (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) - | _ -> lift2_inj Z.mul ik x y - let div ?no_ov ik x y = lift2 Z.div ik x y - let rem ik x y = lift2 Z.rem ik x y - - (* Comparison handling copied from Enums. *) - let handle_bot x y f = match x, y with - | `Bot, `Bot -> `Bot - | `Bot, _ - | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> f () - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let lognot = lift1 Z.lognot - - let logand ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite i -> - (* Except in two special cases *) - if Z.equal i Z.zero then - `Definite Z.zero - else if Z.equal i Z.one then - of_interval IBool (Z.zero, Z.one) - else - top () - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - norm ik @@ lift2 shift_op_big_int ik x y - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - (* TODO: lift does not treat Not {0} as true. *) - let c_logand ik x y = - match to_bool x, to_bool y with - | Some false, _ - | _, Some false -> - of_bool ik false - | _, _ -> - lift2 IntOps.BigIntOps.c_logand ik x y - let c_logor ik x y = - match to_bool x, to_bool y with - | Some true, _ - | _, Some true -> - of_bool ik true - | _, _ -> - lift2 IntOps.BigIntOps.c_logor ik x y - let c_lognot ik = eq ik (of_int ik Z.zero) - - let invariant_ikind e ik (x:t) = - match x with - | `Definite x -> - IntInvariant.of_int e ik x - | `Excluded (s, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let si = IntInvariant.of_excl_list e ik (S.elements s) in - Invariant.(ri && si) - | `Bot -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - let excluded s = from_excl ik s in - let definite x = of_int ik x in - let shrink = function - | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) - | `Bot -> empty - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map excluded (S.arbitrary ()); - 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); - 1, QCheck.always `Bot - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = a - let refine_with_interval ik a b = match a, b with - | x, Some(i) -> meet ik x (of_interval ik i) - | _ -> a - let refine_with_excl_list ik a b = match a, b with - | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) -module Enums : S with type int_t = Z.t = struct - module R = Interval32 (* range for exclusion *) - - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) - - type int_t = Z.t - let name () = "enums" - let bot () = failwith "bot () not implemented for Enums" - let top () = failwith "top () not implemented for Enums" - let bot_of ik = Inc (BISet.empty ()) - let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) - let top_of ik = - match ik with - | IBool -> top_bool - | _ -> Exc (BISet.empty (), size ik) - - let range ik = Size.range ik - - (* - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) - let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 - - let show = function - | Inc xs when BISet.is_empty xs -> "bot" - | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" - | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - (* Normalization function for enums, that handles overflows for Inc. - As we do not compute on Excl, we do not have to perform any overflow handling for it. *) - let norm ikind v = - let min, max = range ikind in - (* Whether the value v lies within the values of the specified ikind. *) - let value_in_ikind v = - Z.compare min v <= 0 && Z.compare v max <= 0 - in - match v with - | Inc xs when BISet.for_all value_in_ikind xs -> v - | Inc xs -> - if should_wrap ikind then - Inc (BISet.map (Size.cast ikind) xs) - else if should_ignore_overflow ikind then - Inc (BISet.filter value_in_ikind xs) - else - top_of ikind - | Exc (xs, r) -> - (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: - let range_in_ikind r = - R.leq r (size ikind) - in - let r_min, r_max = min_of_range r, max_of_range r in - assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) - begin match ikind with - | IBool -> - begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with - | false, false -> top_bool (* Not {} -> {0, 1} *) - | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) - | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) - | true, true -> bot_of ikind (* Not {0, 1} -> bot *) - end - | _ -> - v - end - - - let equal_to i = function - | Inc x -> - if BISet.mem i x then - if BISet.is_singleton x then `Eq - else `Top - else `Neq - | Exc (x, r) -> - if BISet.mem i x then `Neq - else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with - | Exc (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - Exc (s, r) - else if ik = IBool then (* downcast to bool *) - if BISet.mem Z.zero s then - Inc (BISet.singleton Z.one) - else - Exc (BISet.empty(), r') - else (* downcast: may overflow *) - Exc ((BISet.empty ()), r') - | Inc xs -> - let casted_xs = BISet.map (Size.cast ik) xs in - if Cil.isSigned ik && not (BISet.equal xs casted_xs) - then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) - else Inc casted_xs - - let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) - - let of_interval ?(suppress_ovwarn=false) ik (x, y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in - norm ik @@ (Exc (ex, r)) - - let join _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.union x y) - | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) - | Exc (x,r), Inc y - | Inc y, Exc (x,r) -> - let r = if BISet.is_empty y - then r - else - let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in - let range = R.join min_el_range max_el_range in - R.join r range - in - Exc (BISet.diff x y, r) - - let meet _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.inter x y) - | Exc (x,r1), Exc (y,r2) -> - let r = R.meet r1 r2 in - let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in - let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in - (* We remove those elements from the exclusion set that do not fit in the range anyway *) - let excl = BISet.union (filter_by_range x) (filter_by_range y) in - Exc (excl, r) - | Inc x, Exc (y,r) - | Exc (y,r), Inc x -> Inc (BISet.diff x y) - - let widen = join - let narrow = meet - let leq a b = - match a, b with - | Inc xs, Exc (ys, r) -> - if BISet.is_empty xs - then true - else - let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in - let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in - (* Check that the xs fit into the range r *) - Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && - (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) - BISet.for_all (fun x -> not (BISet.mem x ys)) xs - | Inc xs, Inc ys -> - BISet.subset xs ys - | Exc (xs, r), Exc (ys, s) -> - Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) - | Exc (xs, r), Inc ys -> - Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) - - let handle_bot x y f = match is_bot x, is_bot y with - | false, false -> f () - | true, false - | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | true, true -> Inc (BISet.empty ()) - - let lift1 f ikind v = norm ikind @@ match v with - | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) - | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) - | _ -> top_of ikind - - let lift2 f (ikind: Cil.ikind) u v = - handle_bot u v (fun () -> - norm ikind @@ match u, v with - | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) - | _,_ -> top_of ikind) - - let lift2 f ikind a b = - try lift2 f ikind a b with Division_by_zero -> top_of ikind - - let neg ?no_ov = lift1 Z.neg - let add ?no_ov ikind a b = - match a, b with - | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,y -> lift2 Z.add ikind x y - let sub ?no_ov = lift2 Z.sub - let mul ?no_ov ikind a b = - match a, b with - | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b - | x,y -> lift2 Z.mul ikind x y - - let div ?no_ov ikind a b = match a, b with - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | x,y -> lift2 Z.div ikind x y - - let rem = lift2 Z.rem - - let lognot = lift1 Z.lognot - let logand = lift2 Z.logand - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - handle_bot x y (fun () -> - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - lift2 shift_op_big_int ik x y) - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - - let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) - let to_bool = function - | Inc e when BISet.is_empty e -> None - | Exc (e,_) when BISet.is_empty e -> None - | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false - | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true - | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true - | _ -> None - let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None - - let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None - let of_excl_list ik xs = - let min_ik, max_ik = Size.range ik in - let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in - norm ik @@ Exc (exc, size ik) - let is_excl_list = BatOption.is_some % to_excl_list - let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let c_lognot ik x = - if is_bot x - then x - else - match to_bool x with - | Some b -> of_bool ik (not b) - | None -> top_bool - - let c_logand = lift2 IntOps.BigIntOps.c_logand - let c_logor = lift2 IntOps.BigIntOps.c_logor - let maximal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) - | Exc (excl,r) -> - let rec decrement_while_contained v = - if BISet.mem v excl - then decrement_while_contained (Z.pred v) - else v - in - let range_max = Exclusion.max_of_range r in - Some (decrement_while_contained range_max) - | _ (* bottom case *) -> None - - let minimal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) - | Exc (excl,r) -> - let rec increment_while_contained v = - if BISet.mem v excl - then increment_while_contained (Z.succ v) - else v - in - let range_min = Exclusion.min_of_range r in - Some (increment_while_contained range_min) - | _ (* bottom case *) -> None - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let eq ik x y = - handle_bot x y (fun () -> - match x, y with - | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) - | _, _ -> - if is_bot (meet ik x y) then - (* If the meet is empty, there is no chance that concrete values are equal *) - of_bool ik false - else - top_bool) - - let ne ik x y = c_lognot ik (eq ik x y) - - let invariant_ikind e ik x = - match x with - | Inc ps -> - IntInvariant.of_incl_list e ik (BISet.elements ps) - | Exc (ns, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in - Invariant.(ri && nsi) - - - let arbitrary ik = - let open QCheck.Iter in - let neg s = of_excl_list ik (BISet.elements s) in - let pos s = norm ik (Inc s) in - let shrink = function - | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) - | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map neg (BISet.arbitrary ()); - 10, QCheck.map pos (BISet.arbitrary ()); - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = - let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in - match a, b with - | Inc e, None -> bot_of ik - | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) - | _ -> a - - let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) - - let refine_with_excl_list ik a b = - match b with - | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - - let refine_with_incl_list ik a b = - match a, b with - | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) - | _ -> a - - let project ik p t = t -end - -module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = -struct - let name () = "congruences" - type int_t = Z.t - - (* represents congruence class of c mod m, None is bot *) - type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] - - let ( *: ) = Z.mul - let (+:) = Z.add - let (-:) = Z.sub - let (%:) = Z.rem - let (/:) = Z.div - let (=:) = Z.equal - let (<:) x y = Z.compare x y < 0 - let (>:) x y = Z.compare x y > 0 - let (<=:) x y = Z.compare x y <= 0 - let (>=:) x y = Z.compare x y >= 0 - (* a divides b *) - let ( |: ) a b = - if a =: Z.zero then false else (b %: a) =: Z.zero - - let normalize ik x = - match x with - | None -> None - | Some (c, m) -> - if m =: Z.zero then - if should_wrap ik then - Some (Size.cast ik c, m) - else - Some (c, m) - else - let m' = Z.abs m in - let c' = c %: m' in - if c' <: Z.zero then - Some (c' +: m', m') - else - Some (c' %: m', m') - - let range ik = Size.range ik - - let top () = Some (Z.zero, Z.one) - let top_of ik = Some (Z.zero, Z.one) - let bot () = None - let bot_of ik = bot () - - let show = function ik -> match ik with - | None -> "⟂" - | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c - | Some (c, m) -> - let a = if c =: Z.zero then "" else Z.to_string c in - let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in - let c = if a = "" || b = "" then "" else "+" in - a^c^b - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let is_top x = x = top () - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq - | Some (a, b) -> if i %: b =: a then `Top else `Neq - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero - | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 - (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 - Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) - - let leq x y = - let res = leq x y in - if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; - res - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (c1,m1), Some (c2,m2) -> - let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in - normalize ik (Some (c1, m3)) - - let join ik (x:t) y = - let res = join ik x y in - if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; - res - - - let meet ik x y = - (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) - let congruence_series a c m = - let rec next a1 c1 a2 c2 = - if a2 |: a1 then (a2, c2) - else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) - in next m Z.zero a c - in - let simple_case i c m = - if m |: (i -: c) - then Some (i, Z.zero) else None - in - match x, y with - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 - | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 - | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> - let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in - normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) - | _ -> None - - let meet ik x y = - let res = meet ik x y in - if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; - res - - let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None - let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) - let zero = Some (Z.zero, Z.zero) - let one = Some (Z.one, Z.zero) - let top_bool = top() - - let of_bool _ik = function true -> one | false -> zero - - let to_bool (a: t) = match a with - | None -> None - | x when equal zero x -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = top() - - let ending = starting - - let of_congruence ik (c,m) = normalize ik @@ Some(c,m) - - let maximal t = match t with - | Some (x, y) when y =: Z.zero -> Some x - | _ -> None - - let minimal t = match t with - | Some (x,y) when y =: Z.zero -> Some x - | _ -> None - - (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) - let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = - match x with - | None -> None - | Some (c, m) when m =: Z.zero -> - let c' = Size.cast t c in - (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) - (* We go with GCC behavior here: *) - (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) - (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) - (* Clang behaves the same but they never document that anywhere *) - Some (c', m) - | _ -> - let (min_t, max_t) = range t in - let p ikorg = - let (min_ikorg, max_ikorg) = range ikorg in - ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) - in - match torg with - | Some (Cil.TInt (ikorg, _)) when p ikorg -> - if M.tracing then M.trace "cong-cast" "some case"; - x - | _ -> top () - - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = - let pretty_bool _ x = Pretty.text (string_of_bool x) in - let res = cast_to ?torg ?no_ov t x in - if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; - res - - let widen = join - - let widen ik x y = - let res = widen ik x y in - if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; - res - - let narrow = meet - - let log f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) - let c_logand = log (&&) - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let shift_right _ _ _ = top() - - let shift_right ik x y = - let res = shift_right ik x y in - if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; - res - - let shift_left ik x y = - (* Naive primality test *) - (* let is_prime n = - let n = Z.abs n in - let rec is_prime' d = - (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) - in - not (n =: Z.one) && is_prime' (Z.of_int 2) - in *) - match x, y with - | None, None -> None - | None, _ - | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik - | Some (c, m), Some (c', m') -> - let (_, max_ik) = range ik in - if m =: Z.zero && m' =: Z.zero then - normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) - else - let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) - (* TODO: commented out because fails test with _Bool *) - (* if is_prime (m' +: Z.one) then - normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) - else *) - normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) - - let shift_left ik x y = - let res = shift_left ik x y in - if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; - res - - (* Handle unsigned overflows. - From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. - The congruence modulo b may not persist on an overflow. *) - let handle_overflow ik (c, m) = - if m =: Z.zero then - normalize ik (Some (c, m)) - else - (* Find largest m'=2^k (for some k) such that m is divisible by m' *) - let tz = Z.trailing_zeros m in - let m' = Z.shift_left Z.one tz in - - let max = (snd (Size.range ik)) +: Z.one in - if m' >=: max then - (* if m' >= 2 ^ {bitlength}, there is only one value in range *) - let c' = c %: max in - Some (c', Z.zero) - else - normalize ik (Some (c, m')) - - let mul ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) - in - match x, y with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) when no_ov -> - Some (no_ov_case (c1, m1) (c2, m2)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b ) - | _ -> top () - - let mul ?no_ov ik x y = - let res = mul ?no_ov ik x y in - if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; - res - - let neg ?(no_ov=false) ik x = - match x with - | None -> bot() - | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x - - let add ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 +: c2, Z.gcd m1 m2 - in - match (x, y) with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some a, Some b when no_ov -> - normalize ik (Some (no_ov_case a b)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b) - | _ -> top () - - - let add ?no_ov ik x y = - let res = add ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "add : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) - - - let sub ?no_ov ik x y = - let res = sub ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let lognot ik x = match x with - | None -> None - | Some (c, m) -> - if (Cil.isSigned ik) then - sub ik (neg ik x) one - else - let (_, max_ik) = range ik in - Some (Z.sub max_ik c, m) - - (** The implementation of the bit operations could be improved based on the master’s thesis - 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. - see: http://www.es.mdh.se/pdf_publications/948.pdf *) - let bit2 f ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) - else top () - - let logor ik x y = bit2 Z.logor ik x y - - let logand ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then - (* both arguments constant *) - Some (Z.logand c c', Z.zero) - else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then - (* x & 1 and x == c (mod 2*z) *) - (* Value is equal to LSB of c *) - Some (Z.logand c c', Z.zero) - else - top () - - let logxor ik x y = bit2 Z.logxor ik x y - - let rem ik x y = - match x, y with - | None, None -> bot() - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some(c2, m2) -> - if m2 =: Z.zero then - if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then - Some (c1 %: c2, Z.zero) - else - normalize ik (Some (c1, (Z.gcd m1 c2))) - else - normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) - - let rem ik x y = let res = rem ik x y in - if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; - res - - let div ?(no_ov=false) ik x y = - match x,y with - | None, None -> bot () - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, x when leq zero x -> top () - | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () - | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) - | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) - | _, _ -> top () - - - let div ?no_ov ik x y = - let res = div ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty - res ; - res - - let ne ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) - | x, y -> if meet ik x y = None then of_bool ik true else top_bool - - let eq ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) - | x, y -> if meet ik x y <> None then top_bool else of_bool ik false - - let comparison ik op x y = match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) -> - if m1 =: Z.zero && m2 =: Z.zero then - if op c1 c2 then of_bool ik true else of_bool ik false - else - top_bool - - let ge ik x y = comparison ik (>=:) x y - - let ge ik x y = - let res = ge ik x y in - if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let le ik x y = comparison ik (<=:) x y - - let le ik x y = - let res = le ik x y in - if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let gt ik x y = comparison ik (>:) x y - - - let gt ik x y = - let res = gt ik x y in - if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; - res - - let lt ik x y = comparison ik (<:) x y - - let lt ik x y = - let res = lt ik x y in - if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; - res - - let invariant_ikind e ik x = - match x with - | x when is_top x -> Invariant.top () - | Some (c, m) when m =: Z.zero -> - IntInvariant.of_int e ik c - | Some (c, m) -> - let open Cil in - let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in - Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) - | None -> Invariant.none - - let arbitrary ik = - let open QCheck in - let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in - let cong_arb = pair int_arb int_arb in - let of_pair ik p = normalize ik (Some p) in - let to_pair = Option.get in - set_print show (map ~rev:to_pair (of_pair ik) cong_arb) - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =: Z.zero then - if c <: x || c >: y then None else Some (c, Z.zero) - else - let rcx = x +: ((c -: x) %: Z.abs m) in - let lcy = y -: ((y -: c) %: Z.abs m) in - if rcx >: lcy then None - else if rcx =: lcy then Some (rcx, Z.zero) - else cong - | _ -> None - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = - let pretty_intv _ i = - match i with - | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u - | _ -> Pretty.text ("Display Error") in - let refn = refine_with_interval ik cong intv in - if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; - refn - - let refine_with_congruence ik a b = meet ik a b - let refine_with_excl_list ik a b = a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct - - include D - - let lift v = (v, {overflow=false; underflow=false}) - - let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = lift @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = lift @@ D.shift_left ik x y - - let shift_right ik x y = lift @@ D.shift_right ik x y - -end - - - - - - -(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) -(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) -module IntDomTupleImpl = struct - include Printable.Std (* for default invariant, tag, ... *) - - open Batteries - type int_t = Z.t - module I1 = SOverflowLifter (DefExc) - module I2 = Interval - module I3 = SOverflowLifter (Enums) - module I4 = SOverflowLifter (Congruence) - module I5 = IntervalSetFunctor (IntOps.BigIntOps) - module I6 = BitfieldFunctor (IntOps.BigIntOps) - - type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option - [@@deriving eq, ord, hash] - - let name () = "intdomtuple" - - (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) - let no_interval = Tuple6.map2 (const None) - let no_intervalSet = Tuple6.map5 (const None) - - type 'a m = (module SOverflow with type t = 'a) - type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) - - (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) - type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) - type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) - type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) - - type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) - type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) - type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] - type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] - type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] - type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) - let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) - let create r x = (* use where values are introduced *) - create r x (int_precision_from_node_or_config ()) - let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) - let create2 r x = (* use where values are introduced *) - create2 r x (int_precision_from_node_or_config ()) - - let no_overflow ik = function - | Some(_, {underflow; overflow}) -> not (underflow || overflow) - | _ -> false - - let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = - let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in - if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( - let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in - let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in - let underflow = underflow_intv && underflow_intv_set in - let overflow = overflow_intv && overflow_intv_set in - set_overflow_flag ~cast ~underflow ~overflow ik; - ); - no_ov - - let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = - let f b g = if b then Some (g x) else None in - let map x = Option.map fst x in - let intv = f p2 @@ r.fi2_ovc (module I2) in - let intv_set = f p5 @@ r.fi2_ovc (module I5) in - ignore (check_ov ~cast:false ik intv intv_set); - map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) - - let create2_ovc ik r x = (* use where values are introduced *) - create2_ovc ik r x (int_precision_from_node_or_config ()) - - - let opt_map2 f ?no_ov = - curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None - - let to_list x = Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) - let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) - - let exists = function - | (Some true, _, _, _, _,_) - | (_, Some true, _, _, _,_) - | (_, _, Some true, _, _,_) - | (_, _, _, Some true, _,_) - | (_, _, _, _, Some true,_) - | (_, _, _, _, _, Some true) - -> true - | _ -> - false - - let for_all = function - | (Some false, _, _, _, _,_) - | (_, Some false, _, _, _,_) - | (_, _, Some false, _, _,_) - | (_, _, _, Some false, _,_) - | (_, _, _, _, Some false,_) - | (_, _, _, _, _, Some false) - -> - false - | _ -> - true - - (* f0: constructors *) - let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () - let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () - let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } - let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } - let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } - let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} - let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } - let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } - let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } - let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } - let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } - - let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_congruence ik a cong - , opt I2.refine_with_congruence ik b cong - , opt I3.refine_with_congruence ik c cong - , opt I4.refine_with_congruence ik d cong - , opt I5.refine_with_congruence ik e cong - , opt I6.refine_with_congruence ik f cong - ) - - let refine_with_interval ik (a, b, c, d, e,f) intv = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_interval ik a intv - , opt I2.refine_with_interval ik b intv - , opt I3.refine_with_interval ik c intv - , opt I4.refine_with_interval ik d intv - , opt I5.refine_with_interval ik e intv - , opt I6.refine_with_interval ik f intv ) - - let refine_with_excl_list ik (a, b, c, d, e,f) excl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_excl_list ik a excl - , opt I2.refine_with_excl_list ik b excl - , opt I3.refine_with_excl_list ik c excl - , opt I4.refine_with_excl_list ik d excl - , opt I5.refine_with_excl_list ik e excl - , opt I6.refine_with_excl_list ik f excl ) - - let refine_with_incl_list ik (a, b, c, d, e,f) incl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_incl_list ik a incl - , opt I2.refine_with_incl_list ik b incl - , opt I3.refine_with_incl_list ik c incl - , opt I4.refine_with_incl_list ik d incl - , opt I5.refine_with_incl_list ik e incl - , opt I6.refine_with_incl_list ik f incl ) - - - let mapp r (a, b, c, d, e, f) = - let map = BatOption.map in - ( map (r.fp (module I1)) a - , map (r.fp (module I2)) b - , map (r.fp (module I3)) c - , map (r.fp (module I4)) d - , map (r.fp (module I5)) e - , map (r.fp (module I6)) f) - - - let mapp2 r (a, b, c, d, e, f) = - BatOption. - ( map (r.fp2 (module I1)) a - , map (r.fp2 (module I2)) b - , map (r.fp2 (module I3)) c - , map (r.fp2 (module I4)) d - , map (r.fp2 (module I5)) e - , map (r.fp2 (module I6)) f) - - - (* exists/for_all *) - let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } - let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } - let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } - let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } - - let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - ( opt_map2 (r.f2p (module I1)) xa ya - , opt_map2 (r.f2p (module I2)) xb yb - , opt_map2 (r.f2p (module I3)) xc yc - , opt_map2 (r.f2p (module I4)) xd yd - , opt_map2 (r.f2p (module I5)) xe ye - , opt_map2 (r.f2p (module I6)) xf yf) - - (* f2p: binary projections *) - let (%%) f g x = f % (g x) (* composition for binary function g *) - - let leq = - for_all - %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} - - let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) - - let to_excl_list x = - let merge ps = - let (vs, rs) = List.split ps in - let (mins, maxs) = List.split rs in - (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge - - let to_incl_list x = - let hd l = match l with h::t -> h | _ -> [] in - let tl l = match l with h::t -> t | _ -> [] in - let a y = BatSet.of_list (hd y) in - let b y = BatList.map BatSet.of_list (tl y) in - let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge - - let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in - if n = 1 then Some (List.hd xs) - else ( - if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) - None - ) - let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } - - let pretty () x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) - | _ -> - mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x - |> to_list - |> (fun xs -> - text "(" ++ ( - try - List.reduce (fun a b -> a ++ text "," ++ b) xs - with Invalid_argument _ -> - nil) - ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) - - let refine_functions ik : (t -> t) list = - let maybe reffun ik domtup dom = - match dom with Some y -> reffun ik domtup y | _ -> domtup - in - [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e,f) b); (* TODO: get interval across all domains with minimal and maximal *) - (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e,f) d)] - - let refine ik ((a, b, c, d, e,f) : t ) : t = - let dt = ref (a, b, c, d, e,f) in - (match get_refinement () with - | "never" -> () - | "once" -> - List.iter (fun f -> dt := f !dt) (refine_functions ik); - | "fixpoint" -> - let quit_loop = ref false in - while not !quit_loop do - let old_dt = !dt in - List.iter (fun f -> dt := f !dt) (refine_functions ik); - quit_loop := equal old_dt !dt; - if is_bot !dt then dt := bot_of ik; quit_loop := true; - if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; - done; - | _ -> () - ); !dt - - - (* map with overflow check *) - let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = - let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in - let intv = map (r.f1_ovc (module I2)) b in - let intv_set = map (r.f1_ovc (module I5)) e in - let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a - , BatOption.map fst intv - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d - , BatOption.map fst intv_set - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) - - (* map2 with overflow check *) - let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in - let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in - let no_ov = check_ov ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya - , BatOption.map fst intv - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd - , BatOption.map fst intv_set - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) - - let map ik r (a, b, c, d, e, f) = - refine ik - BatOption. - ( map (r.f1 (module I1)) a - , map (r.f1 (module I2)) b - , map (r.f1 (module I3)) c - , map (r.f1 (module I4)) d - , map (r.f1 (module I5)) e - , map (r.f1 (module I6)) f) - - let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - let r = - ( opt_map2 (r.f2 (module I1)) xa ya - , opt_map2 (r.f2 (module I2)) xb yb - , opt_map2 (r.f2 (module I3)) xc yc - , opt_map2 (r.f2 (module I4)) xd yd - , opt_map2 (r.f2 (module I5)) xe ye - , opt_map2 (r.f2 (module I6)) xf yf) - in - if norefine then r else refine ik r - - - (* f1: unary ops *) - let neg ?no_ov ik = - mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} - - let lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} - - let c_lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = - mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} - - (* fp: projections *) - let equal_to i x = - let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple6.enum |> List.of_enum |> List.filter_map identity in - if List.mem `Eq xs then `Eq else - if List.mem `Neq xs then `Neq else - `Top - - let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } - let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } - let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } - (* others *) - let show x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v - | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x - |> to_list - |> String.concat "; " - let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } - - (* `map/opt_map` are used by `project` *) - let opt_map b f = - curry @@ function None, true -> f | x, y when y || b -> x | _ -> None - let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = - ( opt_map keep (r.f3 (module I1)) i1 b1 - , opt_map keep (r.f3 (module I2)) i2 b2 - , opt_map keep (r.f3 (module I3)) i3 b3 - , opt_map keep (r.f3 (module I4)) i4 b4 - , opt_map keep (r.f3 (module I5)) i5 b5 - , opt_map keep (r.f3 (module I6)) i6 b6) - - (** Project tuple t to precision p - * We have to deactivate IntDomains after the refinement, since we might - * lose information if we do it before. E.g. only "Interval" is active - * and shall be projected to only "Def_Exc". By seting "Interval" to None - * before refinement we have no information for "Def_Exc". - * - * Thus we have 3 Steps: - * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element - * 2. Refine the padded t - * 3. Set elements of t to `None` if p is false for this element - * - * Side Note: - * ~keep is used to reuse `map/opt_map` for Step 1 and 3. - * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. - * This way we won't loose any information for the refinement. - * ~keep:false will set the elements to `None` as defined by p *) - let project ik (p: int_precision) t = - let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in - let t_refined = refine ik t_padded in - map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p - - - (* f2: binary ops *) - let join ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} - - let meet ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} - - let widen ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} - - let narrow ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} - - let add ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} - - let sub ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} - - let mul ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} - - let div ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} - - let rem ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} - - let lt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} - - let gt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} - - let le ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} - - let ge ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} - - let eq ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} - - let ne ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} - - let logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} - - let logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} - - let logxor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} - - let shift_left ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} - - let shift_right ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} - - let c_logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} - - let c_logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} - - - (* printing boilerplate *) - let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y - let printXml f x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) - | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) - - let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = - (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) - let simplify_int fallback = - match to_int x with - | Some v -> - (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) - IntInvariant.of_int e ik v - | None -> - fallback () - in - let simplify_all () = - match to_incl_list x with - | Some ps -> - (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) - IntInvariant.of_incl_list e ik ps - | None -> - (* Get interval bounds from all domains (intervals and exclusion set ranges). *) - let min = minimal x in - let max = maximal x in - let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) - (* "Refine" out-of-bounds exclusions for simpler output. *) - let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in - let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in - Invariant.( - IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) - IntInvariant.of_excl_list e ik ns && - Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) - Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) - ) - in - let simplify_none () = - let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in - List.fold_left (fun a i -> - Invariant.(a && i) - ) (Invariant.top ()) is - in - match GobConfig.get_string "ana.base.invariant.int.simplify" with - | "none" -> simplify_none () - | "int" -> simplify_int simplify_none - | "all" -> simplify_int simplify_all - | _ -> assert false - - let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) - - let relift (a, b, c, d, e, f) = - (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) -end - -module IntDomTuple = -struct - module I = IntDomLifter (IntDomTupleImpl) - include I - - let top () = failwith "top in IntDomTuple not supported. Use top_of instead." - let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} - - let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} -end - -let of_const (i, ik, str) = IntDomTuple.of_int ik i +open GobConfig +open GoblintCil +open Pretty +open PrecisionUtil + +module M = Messages + +let (%) = Batteries.(%) +let (|?) = Batteries.(|?) + +exception IncompatibleIKinds of string +exception Unknown +exception Error +exception ArithmeticOnIntegerBot of string + + + +(* Custom Tuple6 as Batteries only provides up to Tuple5 *) +module Tuple6 = struct + type ('a,'b,'c,'d,'e,'f) t = 'a * 'b * 'c * 'd * 'e * 'f + + type 'a enumerable = 'a * 'a * 'a * 'a * 'a * 'a + + let make a b c d e f= (a, b, c, d, e, f) + + let first (a,_,_,_,_, _) = a + let second (_,b,_,_,_, _) = b + let third (_,_,c,_,_, _) = c + let fourth (_,_,_,d,_, _) = d + let fifth (_,_,_,_,e, _) = e + let sixth (_,_,_,_,_, f) = f + + let map f1 f2 f3 f4 f5 f6 (a,b,c,d,e,f) = + let a = f1 a in + let b = f2 b in + let c = f3 c in + let d = f4 d in + let e = f5 e in + let f = f6 f in + (a, b, c, d, e, f) + + let mapn fn (a,b,c,d,e,f) = + let a = fn a in + let b = fn b in + let c = fn c in + let d = fn d in + let e = fn e in + let f = fn f in + (a, b, c, d, e, f) + + let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) + let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) + let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) + let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) + let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) + let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) + + + + + let curry fn a b c d e f= fn (a,b,c,d,e,f) + let uncurry fn (a,b,c,d,e,f) = fn a b c d e f + + let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) + + let of_enum e = match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some a -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some b -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some c -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some d -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some e -> match BatEnum.get e with + None -> failwith "Tuple6.of_enum: not enough elements" + | Some f -> (a,b,c,d,e,f) + + let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e print_f out (a,b,c,d,e,f) = + BatIO.nwrite out first; + print_a out a; + BatIO.nwrite out sep; + print_b out b; + BatIO.nwrite out sep; + print_c out c; + BatIO.nwrite out sep; + print_d out d; + BatIO.nwrite out sep; + print_e out e; + BatIO.nwrite out sep; + print_f out f + BatIO.nwrite out last + + + let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = + print ~first ~sep ~last printer printer printer printer printer out pair + + let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) ?(cmp6=Pervasives.compare) (a1,a2,a3,a4,a5,a6) (b1,b2,b3,b4,b5,b6) = + let c1 = cmp1 a1 b1 in + if c1 <> 0 then c1 else + let c2 = cmp2 a2 b2 in + if c2 <> 0 then c2 else + let c3 = cmp3 a3 b3 in + if c3 <> 0 then c3 else + let c4 = cmp4 a4 b4 in + if c4 <> 0 then c4 else + let c5 = cmp5 a5 b5 in + if c5 <> 0 then c5 else + cmp5 a6 b6 + + open BatOrd + let eq eq1 eq2 eq3 eq4 eq5 eq6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + bin_eq eq1 t1 t1' + (bin_eq eq2 t2 t2' + (bin_eq eq3 t3 t3' + (bin_eq eq4 t4 t4' + (bin_eq eq5 t5 t5' eq6)))) t6 t6' + + let ord ord1 ord2 ord3 ord4 ord5 ord6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + bin_ord ord1 t1 t1' + (bin_ord ord2 t2 t2' + (bin_ord ord3 t3 t3' + (bin_ord ord4 t4 t4' + (bin_ord ord5 t5 t5' ord6)))) t6 t6' + + let comp comp1 comp2 comp3 comp4 comp5 comp6 = + fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> + let c1 = comp1 t1 t1' in + if c1 <> 0 then c1 else + let c2 = comp2 t2 t2' in + if c2 <> 0 then c2 else + let c3 = comp3 t3 t3' in + if c3 <> 0 then c3 else + let c4 = comp4 t4 t4' in + if c4 <> 0 then c4 else + let c5 = comp5 t5 t5' in + if c5 <> 0 then c5 else + comp6 t6 t6' + + module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let eq = eq A.eq B.eq C.eq D.eq E.eq F.eq + end + + module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord ) (F : Ord) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let ord = ord A.ord B.ord C.ord D.ord E.ord F.ord + end + + module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp ) (F : Comp) = struct + type t = A.t * B.t * C.t * D.t * E.t * F.t + let compare = comp A.compare B.compare C.compare D.compare E.compare F.compare + end +end + + + +(** Define records that hold mutable variables representing different Configuration values. + * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) +type ana_int_config_values = { + mutable interval_threshold_widening : bool option; + mutable interval_narrow_by_meet : bool option; + mutable def_exc_widen_by_join : bool option; + mutable interval_threshold_widening_constants : string option; + mutable refinement : string option; +} + +let ana_int_config: ana_int_config_values = { + interval_threshold_widening = None; + interval_narrow_by_meet = None; + def_exc_widen_by_join = None; + interval_threshold_widening_constants = None; + refinement = None; +} + +let get_interval_threshold_widening () = + if ana_int_config.interval_threshold_widening = None then + ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); + Option.get ana_int_config.interval_threshold_widening + +let get_interval_narrow_by_meet () = + if ana_int_config.interval_narrow_by_meet = None then + ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); + Option.get ana_int_config.interval_narrow_by_meet + +let get_def_exc_widen_by_join () = + if ana_int_config.def_exc_widen_by_join = None then + ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); + Option.get ana_int_config.def_exc_widen_by_join + +let get_interval_threshold_widening_constants () = + if ana_int_config.interval_threshold_widening_constants = None then + ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); + Option.get ana_int_config.interval_threshold_widening_constants + +let get_refinement () = + if ana_int_config.refinement = None then + ana_int_config.refinement <- Some (get_string "ana.int.refinement"); + Option.get ana_int_config.refinement + + + +(** Whether for a given ikind, we should compute with wrap-around arithmetic. + * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) +let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" + +(** Whether for a given ikind, we should assume there are no overflows. + * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) +let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" + +let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds +let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) + +type overflow_info = { overflow: bool; underflow: bool;} + +let set_overflow_flag ~cast ~underflow ~overflow ik = + if !AnalysisState.executing_speculative_computations then + (* Do not produce warnings when the operations are not actually happening in code *) + () + else + let signed = Cil.isSigned ik in + if !AnalysisState.postsolving && signed && not cast then + AnalysisState.svcomp_may_overflow := true; + let sign = if signed then "Signed" else "Unsigned" in + match underflow, overflow with + | true, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign + | true, false -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign + | false, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign + | false, false -> assert false + +let reset_lazy () = + ResettableLazy.reset widening_thresholds; + ResettableLazy.reset widening_thresholds_desc; + ana_int_config.interval_threshold_widening <- None; + ana_int_config.interval_narrow_by_meet <- None; + ana_int_config.def_exc_widen_by_join <- None; + ana_int_config.interval_threshold_widening_constants <- None; + ana_int_config.refinement <- None + +module type Arith = +sig + type t + val neg: t -> t + val add: t -> t -> t + val sub: t -> t -> t + val mul: t -> t -> t + val div: t -> t -> t + val rem: t -> t -> t + + val lt: t -> t -> t + val gt: t -> t -> t + val le: t -> t -> t + val ge: t -> t -> t + val eq: t -> t -> t + val ne: t -> t -> t + + val lognot: t -> t + val logand: t -> t -> t + val logor : t -> t -> t + val logxor: t -> t -> t + + val shift_left : t -> t -> t + val shift_right: t -> t -> t + + val c_lognot: t -> t + val c_logand: t -> t -> t + val c_logor : t -> t -> t + +end + +module type ArithIkind = +sig + type t + val neg: Cil.ikind -> t -> t + val add: Cil.ikind -> t -> t -> t + val sub: Cil.ikind -> t -> t -> t + val mul: Cil.ikind -> t -> t -> t + val div: Cil.ikind -> t -> t -> t + val rem: Cil.ikind -> t -> t -> t + + val lt: Cil.ikind -> t -> t -> t + val gt: Cil.ikind -> t -> t -> t + val le: Cil.ikind -> t -> t -> t + val ge: Cil.ikind -> t -> t -> t + val eq: Cil.ikind -> t -> t -> t + val ne: Cil.ikind -> t -> t -> t + + val lognot: Cil.ikind -> t -> t + val logand: Cil.ikind -> t -> t -> t + val logor : Cil.ikind -> t -> t -> t + val logxor: Cil.ikind -> t -> t -> t + + val shift_left : Cil.ikind -> t -> t -> t + val shift_right: Cil.ikind -> t -> t -> t + + val c_lognot: Cil.ikind -> t -> t + val c_logand: Cil.ikind -> t -> t -> t + val c_logor : Cil.ikind -> t -> t -> t + +end + +(* Shared functions between S and Z *) +module type B = +sig + include Lattice.S + type int_t + val bot_of: Cil.ikind -> t + val top_of: Cil.ikind -> t + val to_int: t -> int_t option + val equal_to: int_t -> t -> [`Eq | `Neq | `Top] + + val to_bool: t -> bool option + val to_excl_list: t -> (int_t list * (int64 * int64)) option + val of_excl_list: Cil.ikind -> int_t list -> t + val is_excl_list: t -> bool + + val to_incl_list: t -> int_t list option + + val maximal : t -> int_t option + val minimal : t -> int_t option + + val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t +end + +(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) +module type IkindUnawareS = +sig + include B + include Arith with type t := t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: int_t -> t + val of_bool: bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val arbitrary: unit -> t QCheck.arbitrary + val invariant: Cil.exp -> t -> Invariant.t +end + +(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) +module type S = +sig + include B + include ArithIkind with type t:= t + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val neg : ?no_ov:bool -> Cil.ikind -> t -> t + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t + + val join: Cil.ikind -> t -> t -> t + val meet: Cil.ikind -> t -> t -> t + val narrow: Cil.ikind -> t -> t -> t + val widen: Cil.ikind -> t -> t -> t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val is_top_of: Cil.ikind -> t -> bool + val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t + + val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t + val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t + + val project: Cil.ikind -> int_precision -> t -> t + val arbitrary: Cil.ikind -> t QCheck.arbitrary +end + +module type SOverflow = +sig + + include S + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val of_int : Cil.ikind -> int_t -> t * overflow_info + + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + + val shift_left : Cil.ikind -> t -> t -> t * overflow_info + + val shift_right : Cil.ikind -> t -> t -> t * overflow_info +end + +module type Y = +sig + (* include B *) + include B + include Arith with type t:= t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val is_top_of: Cil.ikind -> t -> bool + + val project: int_precision -> t -> t + val invariant: Cil.exp -> t -> Invariant.t +end + +module type Z = Y with type int_t = Z.t + + +module IntDomLifter (I : S) = +struct + open Cil + type int_t = I.int_t + type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] + + let ikind {ikind; _} = ikind + + (* Helper functions *) + let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) + let lift op x = {x with v = op x.ikind x.v } + (* For logical operations the result is of type int *) + let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} + let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } + let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} + + let bot_of ikind = { v = I.bot_of ikind; ikind} + let bot () = failwith "bot () is not implemented for IntDomLifter." + let is_bot x = I.is_bot x.v + let top_of ikind = { v = I.top_of ikind; ikind} + let top () = failwith "top () is not implemented for IntDomLifter." + let is_top x = I.is_top x.v + + (* Leq does not check for ikind, because it is used in invariant with arguments of different type. + TODO: check ikinds here and fix invariant to work with right ikinds *) + let leq x y = I.leq x.v y.v + let join = lift2 I.join + let meet = lift2 I.meet + let widen = lift2 I.widen + let narrow = lift2 I.narrow + + let show x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + "⊤" + else + I.show x.v (* TODO add ikind to output *) + let pretty () x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + Pretty.text "⊤" + else + I.pretty () x.v (* TODO add ikind to output *) + let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) + let printXml o x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + BatPrintf.fprintf o "\n\n⊤\n\n\n" + else + I.printXml o x.v (* TODO add ikind to output *) + (* This is for debugging *) + let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" + let to_yojson x = I.to_yojson x.v + let invariant e x = + let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in + I.invariant_ikind e' x.ikind x.v + let tag x = I.tag x.v + let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." + let to_int x = I.to_int x.v + let of_int ikind x = { v = I.of_int ikind x; ikind} + let equal_to i x = I.equal_to i x.v + let to_bool x = I.to_bool x.v + let of_bool ikind b = { v = I.of_bool ikind b; ikind} + let to_excl_list x = I.to_excl_list x.v + let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} + let is_excl_list x = I.is_excl_list x.v + let to_incl_list x = I.to_incl_list x.v + let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} + let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} + let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} + let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} + let maximal x = I.maximal x.v + let minimal x = I.minimal x.v + + let neg = lift I.neg + let add = lift2 I.add + let sub = lift2 I.sub + let mul = lift2 I.mul + let div = lift2 I.div + let rem = lift2 I.rem + let lt = lift2_cmp I.lt + let gt = lift2_cmp I.gt + let le = lift2_cmp I.le + let ge = lift2_cmp I.ge + let eq = lift2_cmp I.eq + let ne = lift2_cmp I.ne + let lognot = lift I.lognot + let logand = lift2 I.logand + let logor = lift2 I.logor + let logxor = lift2 I.logxor + let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) + let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) + let c_lognot = lift_logical I.c_lognot + let c_logand = lift2 I.c_logand + let c_logor = lift2 I.c_logor + + let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} + + let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v + + let relift x = { v = I.relift x.v; ikind = x.ikind } + + let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } +end + +module type Ikind = +sig + val ikind: unit -> Cil.ikind +end + +module PtrDiffIkind : Ikind = +struct + let ikind = Cilfacade.ptrdiff_ikind +end + +module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = +struct + include I + let top () = I.top_of (Ik.ikind ()) + let bot () = I.bot_of (Ik.ikind ()) +end + +module Size = struct (* size in bits as int, range as int64 *) + open Cil + let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned + + let top_typ = TInt (ILongLong, []) + let min_for x = intKindForValue x (sign x = `Unsigned) + let bit = function (* bits needed for representation *) + | IBool -> 1 + | ik -> bytesSizeOfInt ik * 8 + let is_int64_big_int x = Z.fits_int64 x + let card ik = (* cardinality *) + let b = bit ik in + Z.shift_left Z.one b + let bits ik = (* highest bits for neg/pos values *) + let s = bit ik in + if isSigned ik then s-1, s-1 else 0, s + let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) + let range ik = + let a,b = bits ik in + let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in + let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) + x,y + + let is_cast_injective ~from_type ~to_type = + let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in + let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in + if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; + Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 + + let cast t x = (* TODO: overflow is implementation-dependent! *) + if t = IBool then + (* C11 6.3.1.2 Boolean type *) + if Z.equal x Z.zero then Z.zero else Z.one + else + let a,b = range t in + let c = card t in + let y = Z.erem x c in + let y = if Z.gt y b then Z.sub y c + else if Z.lt y a then Z.add y c + else y + in + if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); + y + + let min_range_sign_agnostic x = + let size ik = + let a,b = bits_i64 ik in + Int64.neg a,b + in + if sign x = `Signed then + size (min_for x) + else + let a, b = size (min_for x) in + if b <= 64L then + let upper_bound_less = Int64.sub b 1L in + let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in + if x <= max_one_less then + a, upper_bound_less + else + a,b + else + a, b + + (* From the number of bits used to represent a positive value, determines the maximal representable value *) + let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) + + (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) + let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) + +end + + +module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct + open B + (* these should be overwritten for better precision if possible: *) + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let starting ?(suppress_ovwarn=false) ik x = top_of ik + let ending ?(suppress_ovwarn=false) ik x = top_of ik + let maximal x = None + let minimal x = None +end + +module Std (B: sig + type t + val name: unit -> string + val top_of: Cil.ikind -> t + val bot_of: Cil.ikind -> t + val show: t -> string + val equal: t -> t -> bool + end) = struct + include Printable.StdLeaf + let name = B.name (* overwrite the one from Printable.Std *) + open B + let is_top x = failwith "is_top not implemented for IntDomain.Std" + let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind + This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) + let is_top_of ik x = B.equal x (top_of ik) + + (* all output is based on B.show *) + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) + let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y + + include StdTop (B) +end + +(* Textbook interval arithmetic, without any overflow handling etc. *) +module IntervalArith (Ints_t : IntOps.IntOps) = struct + let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) + let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) + + let mul (x1, x2) (y1, y2) = + let x1y1 = (Ints_t.mul x1 y1) in + let x1y2 = (Ints_t.mul x1 y2) in + let x2y1 = (Ints_t.mul x2 y1) in + let x2y2 = (Ints_t.mul x2 y2) in + (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) + + let shift_left (x1,x2) (y1,y2) = + let y1p = Ints_t.shift_left Ints_t.one y1 in + let y2p = Ints_t.shift_left Ints_t.one y2 in + mul (x1, x2) (y1p, y2p) + + let div (x1, x2) (y1, y2) = + let x1y1n = (Ints_t.div x1 y1) in + let x1y2n = (Ints_t.div x1 y2) in + let x2y1n = (Ints_t.div x2 y1) in + let x2y2n = (Ints_t.div x2 y2) in + let x1y1p = (Ints_t.div x1 y1) in + let x1y2p = (Ints_t.div x1 y2) in + let x2y1p = (Ints_t.div x2 y1) in + let x2y2p = (Ints_t.div x2 y2) in + (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) + + let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) + let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) + + let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) + + let one = (Ints_t.one, Ints_t.one) + let zero = (Ints_t.zero, Ints_t.zero) + let top_bool = (Ints_t.zero, Ints_t.one) + + let to_int (x1, x2) = + if Ints_t.equal x1 x2 then Some x1 else None + + let upper_threshold u max_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + let max_ik' = Ints_t.to_bigint max_ik in + let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in + BatOption.map_default Ints_t.of_bigint max_ik t + let lower_threshold l min_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + let min_ik' = Ints_t.to_bigint min_ik in + let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in + BatOption.map_default Ints_t.of_bigint min_ik t + let is_upper_threshold u = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + List.exists (Z.equal u) ts + let is_lower_threshold l = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + List.exists (Z.equal l) ts +end + +module IntInvariant = +struct + let of_int e ik x = + if get_bool "witness.invariant.exact" then + Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) + else + Invariant.none + + let of_incl_list e ik ps = + match ps with + | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> + assert (List.mem Z.zero ps); + assert (List.mem Z.one ps); + Invariant.none + | [_] when get_bool "witness.invariant.exact" -> + Invariant.none + | _ :: _ :: _ + | [_] | [] -> + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in + Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) (Invariant.bot ()) ps + + let of_interval_opt e ik = function + | (Some x1, Some x2) when Z.equal x1 x2 -> + of_int e ik x1 + | x1_opt, x2_opt -> + let (min_ik, max_ik) = Size.range ik in + let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in + let i1 = + match x1_opt, inexact_type_bounds with + | Some x1, false when Z.equal min_ik x1 -> Invariant.none + | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) + | None, _ -> Invariant.none + in + let i2 = + match x2_opt, inexact_type_bounds with + | Some x2, false when Z.equal x2 max_ik -> Invariant.none + | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) + | None, _ -> Invariant.none + in + Invariant.(i1 && i2) + + let of_interval e ik (x1, x2) = + of_interval_opt e ik (Some x1, Some x2) + + let of_excl_list e ik ns = + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in + Invariant.(a && i) + ) (Invariant.top ()) ns +end + +module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = +struct + let name () = "intervals" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] + module IArith = IntervalArith (Ints_t) + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + let top_of ik = Some (range ik) + let bot () = None + let bot_of ik = bot () (* TODO: improve *) + + let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) -> + if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> + if Ints_t.compare x y > 0 then + (None,{underflow=false; overflow=false}) + else ( + let (min_ik, max_ik) = range ik in + let underflow = Ints_t.compare min_ik x > 0 in + let overflow = Ints_t.compare max_ik y < 0 in + let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in + let v = + if underflow || overflow then + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in + let resdiff = Ints_t.abs (Ints_t.sub y x) in + if Ints_t.compare resdiff diff > 0 then + top_of ik + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if Ints_t.compare l u <= 0 then + Some (l, u) + else + (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) + top_of ik + else if not cast && should_ignore_overflow ik then + let tl, tu = BatOption.get @@ top_of ik in + Some (Ints_t.max tl x, Ints_t.min tu y) + else + top_of ik + else + Some (x,y) + in + (v, ov_info) + ) + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst + + let meet ik (x:t) y = + match x, y with + | None, z | z, None -> None + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst + + (* TODO: change to_int signature so it returns a big_int *) + let to_int x = Option.bind x (IArith.to_int) + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) + let of_int ik (x: int_t) = of_interval ik (x,x) + let zero = Some IArith.zero + let one = Some IArith.one + let top_bool = Some IArith.top_bool + + let of_bool _ik = function true -> one | false -> zero + let to_bool (a: t) = match a with + | None -> None + | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) + + (* TODO: change signature of maximal, minimal to return big_int*) + let maximal = function None -> None | Some (x,y) -> Some y + let minimal = function None -> None | Some (x,y) -> Some x + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) + + let widen ik x y = + match x, y with + | None, z | z, None -> z + | Some (l0,u0), Some (l1,u1) -> + let (min_ik, max_ik) = range ik in + let threshold = get_interval_threshold_widening () in + let l2 = + if Ints_t.compare l0 l1 = 0 then l0 + else if threshold then IArith.lower_threshold l1 min_ik + else min_ik + in + let u2 = + if Ints_t.compare u0 u1 = 0 then u0 + else if threshold then IArith.upper_threshold u1 max_ik + else max_ik + in + norm ik @@ Some (l2,u2) |> fst + let widen ik x y = + let r = widen ik x y in + if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; + assert (leq x y); (* TODO: remove for performance reasons? *) + r + + let narrow ik x y = + match x, y with + | _,None | None, _ -> None + | Some (x1,x2), Some (y1,y2) -> + let threshold = get_interval_threshold_widening () in + let (min_ik, max_ik) = range ik in + let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in + let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in + norm ik @@ Some (lr,ur) |> fst + + + let narrow ik x y = + if get_interval_narrow_by_meet () then + meet ik x y + else + narrow ik x y + + let log f ~annihilator ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) ~annihilator:true + let c_logand = log (&&) ~annihilator:false + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let bit f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + let bitcomp f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let logxor = bit (fun _ik -> Ints_t.logxor) + + let logand ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) + | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst + | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst + | _ -> top_of ik + + let logor = bit (fun _ik -> Ints_t.logor) + + let bit1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_int i1 with + | Some x -> of_int ik (f ik x) |> fst + | _ -> top_of ik + + let lognot = bit1 (fun _ik -> Ints_t.lognot) + let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) + + let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) + + let binary_op_with_norm ?no_ov op ik x y = match x, y with + | None, None -> (None, {overflow=false; underflow= false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some x, Some y -> norm ik @@ Some (op x y) + + let add ?no_ov = binary_op_with_norm IArith.add + let mul ?no_ov = binary_op_with_norm IArith.mul + let sub ?no_ov = binary_op_with_norm IArith.sub + + let shift_left ik a b = + match is_bot a, is_bot b with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) + | _ -> + match a, minimal b, maximal b with + | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> + (try + let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in + norm ik @@ Some r + with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let rem ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (xl, xu), Some (yl, yu) -> + if is_top_of ik x && is_top_of ik y then + (* This is needed to preserve soundness also on things bigger than int32 e.g. *) + (* x: 3803957176L -> T in Interval32 *) + (* y: 4209861404L -> T in Interval32 *) + (* x % y: 3803957176L -> T in Interval32 *) + (* T in Interval32 is [-2147483648,2147483647] *) + (* the code below computes [-2147483647,2147483647] for this though which is unsound *) + top_of ik + else + (* If we have definite values, Ints_t.rem will give a definite result. + * Otherwise we meet with a [range] the result can be in. + * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. + * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) + let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in + let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in + let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range + + let rec div ?no_ov ik x y = + match x, y with + | None, None -> (bot (),{underflow=false; overflow=false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | (Some (x1,x2) as x), (Some (y1,y2) as y) -> + begin + let is_zero v = Ints_t.compare v Ints_t.zero = 0 in + match y1, y2 with + | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) + | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) + | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) + | _ -> binary_op_with_norm IArith.div ik x y + end + + let ne ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik true + else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then + of_bool ik false + else top_bool + + let eq ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then + of_bool ik true + else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik false + else top_bool + + let ge ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 then of_bool ik true + else if Ints_t.compare x2 y1 < 0 then of_bool ik false + else top_bool + + let le ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 <= 0 then of_bool ik true + else if Ints_t.compare y2 x1 < 0 then of_bool ik false + else top_bool + + let gt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 then of_bool ik true + else if Ints_t.compare x2 y1 <= 0 then of_bool ik false + else top_bool + + let lt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 < 0 then of_bool ik true + else if Ints_t.compare y2 x1 <= 0 then of_bool ik false + else top_bool + + let invariant_ikind e ik = function + | Some (x1, x2) -> + let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in + IntInvariant.of_interval e ik (x1', x2') + | None -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink = function + | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | None -> empty + in + QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) + + let modulo n k = + let result = Ints_t.rem n k in + if Ints_t.compare result Ints_t.zero >= 0 then result + else Ints_t.add result k + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None + else if Ints_t.equal m Ints_t.zero then + Some (c, c) + else + let (min_ik, max_ik) = range ik in + let rcx = + if Ints_t.equal x min_ik then x else + Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in + let lcy = + if Ints_t.equal y max_ik then y else + Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in + if Ints_t.compare rcx lcy > 0 then None + else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst + else norm ik @@ Some (rcx, lcy) |> fst + | _ -> None + + let refine_with_congruence ik x y = + let refn = refine_with_congruence ik x y in + if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; + refn + + let refine_with_interval ik a b = meet ik a b + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + match intv, excl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls, (rl, rh)) -> + let rec shrink op b = + let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in + if not (Ints_t.equal b new_b) then shrink op new_b else new_b + in + let (min_ik, max_ik) = range ik in + let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in + let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in + let intv' = norm ik @@ Some (l', u') |> fst in + let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in + meet ik intv' range + + let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = + match intv, incl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls) -> + let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in + let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in + match min None ls, max None ls with + | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) + | _, _-> intv + + let project ik p t = t +end + +module BitFieldArith (Ints_t : IntOps.IntOps) = struct + let zero_mask = Ints_t.zero + let one_mask = Ints_t.lognot zero_mask + + let of_int x = (Ints_t.lognot x, x) + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + + let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + + let is_constant (z,o) = (Ints_t.logxor z o) = one_mask + + let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) + + let nabla x y= if x = Ints_t.logor x y then x else one_mask + + let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) + + let lognot (z,o) = (o,z) + + let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), + Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) + + let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) + + let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) + + let min ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + let max ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + + if isSigned ik then + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero + +end + +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct + let name () = "bitfield" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] + + module BArith = BitFieldArith (Ints_t) + + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = top () + let bot_of ik = bot () + + let range ik bf = (BArith.min ik bf, BArith.max ik bf) + + let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) + + let norm ?(suppress_ovwarn=false) ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + + let (min,max) = range ik (z,o) in + let underflow = Z.compare min min_ik < 0 in + let overflow = Z.compare max max_ik > 0 in + + let new_bitfield= + (if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo)) + in + if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) + else (new_bitfield, {underflow=underflow; overflow=overflow}) + + let show t = + if t = bot () then "bot" else + if t = top () then "top" else + let (z,o) = t in + if BArith.is_constant t then + Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) + else + Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst + + let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst + + let leq (x:t) (y:t) = (BArith.join x y) = y + + let widen ik x y = (norm ik @@ BArith.widen x y) |> fst + let narrow ik x y = y + + let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) + + let to_int (z,o) = if is_bot (z,o) then None else + if BArith.is_constant (z,o) then Some o + else None + + let equal_to i bf = + if BArith.of_int i = bf then `Eq + else if leq (BArith.of_int i) bf then `Top + else `Neq + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + (* naive implentation -> horrible O(n) runtime *) + let (min_ik, max_ik) = Size.range ik in + let result = ref (bot ()) in + let current = ref (min_ik) in + let bf = ref (bot ()) in + while Z.leq !current max_ik do + bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); + current := Z.add !current Z.one + done; + norm ~suppress_ovwarn ik !result + + let of_bool _ik = function true -> BArith.one | false -> BArith.zero + + let to_bool d = + if not (leq BArith.zero d) then Some true + else if BArith.eq d BArith.zero then Some false + else None + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t + + + (* Logic *) + + let log1 f ik i1 = match to_bool i1 with + | None -> top_of ik + | Some x -> of_bool ik (f x) + + let log2 f ik i1 i2 = match (to_bool i1, to_bool i2) with + | None, None -> top_of ik + | None, Some x | Some x, None -> of_bool ik x + | Some x, Some y -> of_bool ik (f x y) + let c_logor ik i1 i2 = log2 (||) ik i1 i2 + + let c_logand ik i1 i2 = log2 (&&) ik i1 i2 + + let c_lognot ik i1 = log1 not ik i1 + + + (* Bitwise *) + + let logxor ik i1 i2 = BArith.logxor i1 i2 + + let logand ik i1 i2 = BArith.logand i1 i2 + + let logor ik i1 i2 = BArith.logor i1 i2 + + let lognot ik i1 = BArith.lognot i1 + + let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) + + let shift_left ik a b = (top_of ik,{underflow=false; overflow=false}) + + + (* Arith *) + + (* + add, sub and mul based on the paper + "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" + of Vishwanathan et al. + *) + + let add ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let sv = Ints_t.add pv qv in + let sm = Ints_t.add pm qm in + let sigma = Ints_t.add sv sm in + let chi = Ints_t.logxor sigma sv in + let mu = Ints_t.logor (Ints_t.logor pm qm) chi in + let rv = Ints_t.logand sv (Ints_t.lognot mu) in + let rm = mu in + let o3 = Ints_t.logor rv rm in + let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + ((z3, o3),{underflow=false; overflow=false}) + + let sub ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let dv = Ints_t.sub pv qv in + let alpha = Ints_t.add dv pm in + let beta = Ints_t.sub dv qm in + let chi = Ints_t.logxor alpha beta in + let mu = Ints_t.logor (Ints_t.logor pm qm) chi in + let rv = Ints_t.logand dv (Ints_t.lognot mu) in + let rm = mu in + let o3 = Ints_t.logor rv rm in + let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + ((z3, o3),{underflow=false; overflow=false}) + + let neg ?no_ov ik x = + M.trace "bitfield" "neg"; + sub ?no_ov ik BArith.zero x + + let mul ?no_ov ik (z1, o1) (z2, o2) = + let z1 = ref z1 in + let o1 = ref o1 in + let z2 = ref z2 in + let o2 = ref o2 in + let z3 = ref BArith.one_mask in + let o3 = ref BArith.zero_mask in + for i = Size.bit ik downto 0 do + if Ints_t.logand !o1 Ints_t.one == Ints_t.one then + if Ints_t.logand !z1 Ints_t.one == Ints_t.one then + let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in + z3 := Ints_t.logor !z3 tmp; + o3 := Ints_t.logor !o3 tmp + else + let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in + z3 := fst tmp; + o3 := snd tmp + ; + z1 := Ints_t.shift_right !z1 1; + o1 := Ints_t.shift_right !o1 1; + z2 := Ints_t.shift_left !z2 1; + o2 := Ints_t.shift_left !o2 1; + done; + ((!z3, !o3),{underflow=false; overflow=false}) + + let rec div ?no_ov ik (z1, o1) (z2, o2) = + if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) + else (top_of ik,{underflow=false; overflow=false}) + + let rem ik x y = + M.trace "bitfield" "rem"; + if BArith.is_constant x && BArith.is_constant y then ( + (* x % y = x - (x / y) * y *) + let tmp = fst (div ik x y) in + let tmp = fst (mul ik tmp y) in + fst (sub ik x tmp)) + else top_of ik + + let eq ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) + else if not (leq x y || leq y x) then of_bool ik false + else BArith.top_bool + + let ne ik x y = + if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) + else if not (leq x y || leq y x) then of_bool ik true + else BArith.top_bool + + let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true + else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false + else BArith.top_bool + + let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false + else BArith.top_bool + + let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true + else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false + else BArith.top_bool + + let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false + else BArith.top_bool + + + let invariant_ikind e ik (z,o) = + let range = range ik (z,o) in + IntInvariant.of_interval e ik range + + let starting ?(suppress_ovwarn=false) ik n = + if Ints_t.compare n Ints_t.zero >= 0 then + (* sign bit can only be 0, as all numbers will be positive *) + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let zs = BArith.one_mask in + let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + (norm ~suppress_ovwarn ik @@ (zs,os)) + else + (norm ~suppress_ovwarn ik @@ (top ())) + + let ending ?(suppress_ovwarn=false) ik n = + if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then + (* sign bit can only be 1, as all numbers will be negative *) + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + let os = BArith.one_mask in + (norm ~suppress_ovwarn ik @@ (zs,os)) + else + (norm ~suppress_ovwarn ik @@ (top ())) + + let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in + match intv, cong with + | (z,o), Some (c, m) -> + if is_power_of_two m then + let congruenceMask = Ints_t.lognot m in + let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in + let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + (newz, newo) + else + top_of ik + | _ -> top_of ik + + let refine_with_interval ik t i = t + + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t + + let invariant_ikind e ik = + M.trace "bitfield" "invariant_ikind"; + failwith "Not implemented" + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + M.trace "bitfield" "refine_with_congruence"; + t + + let refine_with_interval ik a b = + M.trace "bitfield" "refine_with_interval"; + t + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + M.trace "bitfield" "refine_with_excl_list"; + t + + let refine_with_incl_list ik t (incl : (int_t list) option) : t = + (* loop over all included ints *) + let incl_list_masks = match incl with + | None -> t + | Some ls -> + List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls + in + BArith.meet t incl_list_masks + + let arbitrary ik = + let open QCheck.Iter in + let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb1 int_arb2 in + let shrink = function + | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) + in + QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) + + let project ik p t = t +end + + +(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) +module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = +struct + + module Interval = IntervalFunctor (Ints_t) + module IArith = IntervalArith (Ints_t) + + + let name () = "interval_sets" + + type int_t = Ints_t.t + + let (>.) a b = Ints_t.compare a b > 0 + let (=.) a b = Ints_t.compare a b = 0 + let (<.) a b = Ints_t.compare a b < 0 + let (>=.) a b = Ints_t.compare a b >= 0 + let (<=.) a b = Ints_t.compare a b <= 0 + let (+.) a b = Ints_t.add a b + let (-.) a b = Ints_t.sub a b + + (* + Each domain's element is guaranteed to be in canonical form. That is, each interval contained + inside the set does not overlap with each other and they are not adjacent. + *) + type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + + let top_of ik = [range ik] + + let bot () = [] + + let bot_of ik = bot () + + let show (x: t) = + let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in + List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" + + (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) + type event = Enter of Ints_t.t | Exit of Ints_t.t + + let unbox_event = function Enter x -> x | Exit x -> x + + let cmp_events x y = + (* Deliberately comparing ints first => Cannot be derived *) + let res = Ints_t.compare (unbox_event x) (unbox_event y) in + if res <> 0 then res + else + begin + match (x, y) with + | (Enter _, Exit _) -> -1 + | (Exit _, Enter _) -> 1 + | (_, _) -> 0 + end + + let interval_set_to_events (xs: t) = + List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs + + let two_interval_sets_to_events (xs: t) (ys: t) = + let xs = interval_set_to_events xs in + let ys = interval_set_to_events ys in + List.merge cmp_events xs ys + + (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap + This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) + let combined_event_list lattice_op (xs:event list) = + let l = match lattice_op with `Join -> 1 | `Meet -> 2 in + let aux (interval_count, acc) = function + | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) + | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) + in + List.fold_left aux (0, []) xs |> snd |> List.rev + + let rec events_to_intervals = function + | [] -> [] + | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) + | _ -> failwith "Invalid events list" + + let remove_empty_gaps (xs: t) = + let aux acc (l, r) = match acc with + | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' + | _ -> (l, r)::acc + in + List.fold_left aux [] xs |> List.rev + + let canonize (xs: t) = + interval_set_to_events xs |> + List.sort cmp_events |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let unop (x: t) op = match x with + | [] -> [] + | _ -> canonize @@ List.concat_map op x + + let binop (x: t) (y: t) op : t = match x, y with + | [], _ -> [] + | _, [] -> [] + | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) + + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let minimal = function + | [] -> None + | (x, _)::_ -> Some x + + let maximal = function + | [] -> None + | xs -> Some (BatList.last xs |> snd) + + let equal_to_interval i (a, b) = + if a =. b && b =. i then + `Eq + else if a <=. i && i <=. b then + `Top + else + `Neq + + let equal_to i xs = match List.map (equal_to_interval i) xs with + | [] -> failwith "unsupported: equal_to with bottom" + | [`Eq] -> `Eq + | ys when List.for_all ((=) `Neq) ys -> `Neq + | _ -> `Top + + let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = + if x >. y then + ([],{underflow=false; overflow=false}) + else + let (min_ik, max_ik) = range ik in + let underflow = min_ik >. x in + let overflow = max_ik <. y in + let v = if underflow || overflow then + begin + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (max_ik -. min_ik) in + let resdiff = Ints_t.abs (y -. x) in + if resdiff >. diff then + [range ik] + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if l <=. u then + [(l, u)] + else + (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) + [(min_ik, u); (l, max_ik)] + else if not cast && should_ignore_overflow ik then + [Ints_t.max min_ik x, Ints_t.min max_ik y] + else + [range ik] + end + else + [(x,y)] + in + if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) + + let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = + let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) + + let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> + let res = List.map op (BatList.cartesian_product x y) in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let unary_op_with_norm op (ik:ikind) (x: t) = match x with + | [] -> ([],{overflow=false; underflow=false}) + | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x + + let rec leq (xs: t) (ys: t) = + let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in + match xs, ys with + | [], _ -> true + | _, [] -> false + | (xl,xr)::xs', (yl,yr)::ys' -> + if leq_interval (xl,xr) (yl,yr) then + leq xs' ys + else if xr <. yl then + false + else + leq xs ys' + + let join ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let meet ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Meet |> + events_to_intervals + + let to_int = function + | [x] -> IArith.to_int x + | _ -> None + + let zero = [IArith.zero] + let one = [IArith.one] + let top_bool = [IArith.top_bool] + + let not_bool (x:t) = + let is_false x = equal x zero in + let is_true x = equal x one in + if is_true x then zero else if is_false x then one else top_bool + + let to_bool = function + | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false + | x -> if leq zero x then None else Some true + + let of_bool _ = function true -> one | false -> zero + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) + + let of_int ik (x: int_t) = of_interval ik (x, x) + + let lt ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <. min_y then + of_bool ik true + else if min_x >=. max_y then + of_bool ik false + else + top_bool + + let le ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <=. min_y then + of_bool ik true + else if min_x >. max_y then + of_bool ik false + else + top_bool + + let gt ik x y = not_bool @@ le ik x y + + let ge ik x y = not_bool @@ lt ik x y + + let eq ik x y = match x, y with + | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> + one + | _ -> + if is_bot (meet ik x y) then + zero + else + top_bool + + let ne ik x y = not_bool @@ eq ik x y + let interval_to_int i = Interval.to_int (Some i) + let interval_to_bool i = Interval.to_bool (Some i) + + let log f ik (i1, i2) = + match (interval_to_bool i1, interval_to_bool i2) with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + + let bit f ik (i1, i2) = + match (interval_to_int i1), (interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + + let bitcomp f ik (i1, i2) = + match (interval_to_int i1, interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) + | _, _ -> (top_of ik,{overflow=false; underflow=false}) + + let logand ik x y = + let interval_logand = bit Ints_t.logand ik in + binop x y interval_logand + + let logor ik x y = + let interval_logor = bit Ints_t.logor ik in + binop x y interval_logor + + let logxor ik x y = + let interval_logxor = bit Ints_t.logxor ik in + binop x y interval_logxor + + let lognot ik x = + let interval_lognot i = + match interval_to_int i with + | Some x -> of_int ik (Ints_t.lognot x) |> fst + | _ -> top_of ik + in + unop x interval_lognot + + let shift_left ik x y = + let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftleft + + let shift_right ik x y = + let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftright + + let c_lognot ik x = + let log1 f ik i1 = + match interval_to_bool i1 with + | Some x -> of_bool ik (f x) + | _ -> top_of ik + in + let interval_lognot = log1 not ik in + unop x interval_lognot + + let c_logand ik x y = + let interval_logand = log (&&) ik in + binop x y interval_logand + + let c_logor ik x y = + let interval_logor = log (||) ik in + binop x y interval_logor + + let add ?no_ov = binary_op_with_norm IArith.add + let sub ?no_ov = binary_op_with_norm IArith.sub + let mul ?no_ov = binary_op_with_norm IArith.mul + let neg ?no_ov = unary_op_with_norm IArith.neg + + let div ?no_ov ik x y = + let rec interval_div x (y1, y2) = begin + let top_of ik = top_of ik |> List.hd in + let is_zero v = v =. Ints_t.zero in + match y1, y2 with + | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) + | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) + | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik + | _ -> IArith.div x (y1, y2) + end + in binary_op_with_norm interval_div ik x y + + let rem ik x y = + let interval_rem (x, y) = + if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then + top_of ik + else + let (xl, xu) = x in let (yl, yu) = y in + let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in + let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in + let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit Ints_t.rem ik (x, y)) [range] + in + binop x y interval_rem + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x + + (* + narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys + *) + let narrow ik xs ys = match xs ,ys with + | [], _ -> [] | _ ,[] -> xs + | _, _ -> + let min_xs = minimal xs |> Option.get in + let max_xs = maximal xs |> Option.get in + let min_ys = minimal ys |> Option.get in + let max_ys = maximal ys |> Option.get in + let min_range,max_range = range ik in + let threshold = get_interval_threshold_widening () in + let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in + let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in + xs + |> (function (_, y)::z -> (min, y)::z | _ -> []) + |> List.rev + |> (function (x, _)::z -> (x, max)::z | _ -> []) + |> List.rev + + (* + 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. + and joins all intervals in xs assigned to the same interval in ys as one interval. + 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. + 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) + + The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. + *) + let widen ik xs ys = + let (min_ik,max_ik) = range ik in + let threshold = get_bool "ana.int.interval_threshold_widening" in + let upper_threshold (_,u) = IArith.upper_threshold u max_ik in + let lower_threshold (l,_) = IArith.lower_threshold l min_ik in + (*obtain partitioning of xs intervals according to the ys interval that includes them*) + let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= + match xs,ys with + | _, [] -> [] + | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys + | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) + | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys + in + let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in + (*merge a pair of adjacent partitions*) + let merge_pair ik (a,b) (c,d) = + let new_a = function + | None -> Some (upper_threshold b, upper_threshold b) + | Some (ax,ay) -> Some (ax, upper_threshold b) + in + let new_c = function + | None -> Some (lower_threshold d, lower_threshold d) + | Some (cx,cy) -> Some (lower_threshold d, cy) + in + if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then + [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] + else + [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] + in + let partitions_are_approaching part_left part_right = match part_left, part_right with + | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) + | _,_ -> false + in + (*merge all approaching pairs of adjacent partitions*) + let rec merge_list ik = function + | [] -> [] + | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) + | x::xs -> x :: merge_list ik xs + in + (*expands left extremity*) + let widen_left = function + | [] -> [] + | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts + | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts + | x -> x + in + (*expands right extremity*) + let widen_right x = + let map_rightmost = function + | [] -> [] + | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts + | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts + | x -> x + in + List.rev x |> map_rightmost |> List.rev + in + interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd + + let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) + + let invariant_ikind e ik xs = + List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> + let open Invariant in List.fold_left (||) (bot ()) + + let modulo n k = + let result = Ints_t.rem n k in + if result >=. Ints_t.zero then result + else result +. k + + let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = + let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =. Ints_t.zero && (c <. x || c >. y) then [] + else if m =. Ints_t.zero then + [(c, c)] + else + let (min_ik, max_ik) = range ik in + let rcx = + if x =. min_ik then x else + x +. (modulo (c -. x) (Ints_t.abs m)) in + let lcy = + if y =. max_ik then y else + y -. (modulo (y -. c) (Ints_t.abs m)) in + if rcx >. lcy then [] + else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst + else norm_interval ik (rcx, lcy) |> fst + | _ -> [] + in + List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs + + let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] + + let refine_with_incl_list ik intvs = function + | None -> intvs + | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) + + let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = + let intv1 = (min, excl -. Ints_t.one) in + let intv2 = (excl +. Ints_t.one, max) in + norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst + + let of_excl_list ik (excls: int_t list) = + let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in + let res = List.fold_left (meet ik) (top_of ik) excl_list in + res + + let refine_with_excl_list ik (intv : t) = function + | None -> intv + | Some (xs, range) -> + let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = + excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl + in + let excl_list = List.map (excl_to_intervalset ik range) xs in + List.fold_left (meet ik) intv excl_list + + let project ik p t = t + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let list_pair_arb = QCheck.small_list pair_arb in + let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in + let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list + in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) +end + +module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct + include D + + let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = fst @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = fst @@ D.shift_left ik x y + + let shift_right ik x y = fst @@ D.shift_right ik x y +end + +module IntIkind = struct let ikind () = Cil.IInt end +module Interval = IntervalFunctor (IntOps.BigIntOps) +module Bitfield = BitfieldFunctor (IntOps.BigIntOps) +module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) +module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) +module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) +struct + include Printable.Std + let name () = "integers" + type t = Ints_t.t [@@deriving eq, ord, hash] + type int_t = Ints_t.t + let top () = raise Unknown + let bot () = raise Error + let top_of ik = top () + let bot_of ik = bot () + let show (x: Ints_t.t) = Ints_t.to_string x + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) + let is_top _ = false + let is_bot _ = false + + let equal_to i x = if i > x then `Neq else `Top + let leq x y = x <= y + let join x y = if Ints_t.compare x y > 0 then x else y + let widen = join + let meet x y = if Ints_t.compare x y > 0 then y else x + let narrow = meet + + let of_bool x = if x then Ints_t.one else Ints_t.zero + let to_bool' x = x <> Ints_t.zero + let to_bool x = Some (to_bool' x) + let of_int x = x + let to_int x = Some x + + let neg = Ints_t.neg + let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) + let sub = Ints_t.sub + let mul = Ints_t.mul + let div = Ints_t.div + let rem = Ints_t.rem + let lt n1 n2 = of_bool (n1 < n2) + let gt n1 n2 = of_bool (n1 > n2) + let le n1 n2 = of_bool (n1 <= n2) + let ge n1 n2 = of_bool (n1 >= n2) + let eq n1 n2 = of_bool (n1 = n2) + let ne n1 n2 = of_bool (n1 <> n2) + let lognot = Ints_t.lognot + let logand = Ints_t.logand + let logor = Ints_t.logor + let logxor = Ints_t.logxor + let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) + let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) + let c_lognot n1 = of_bool (not (to_bool' n1)) + let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) + let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) + let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." + let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) + let invariant _ _ = Invariant.none (* TODO *) +end + +module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) +struct + include Integers(IntOps.Int64Ops) + let top () = raise Unknown + let bot () = raise Error + let leq = equal + let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y + let join x y = if equal x y then x else top () + let meet x y = if equal x y then x else bot () +end + +module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) +struct + type int_t = Base.int_t + include Lattice.FlatConf (struct + include Printable.DefaultConf + let top_name = "Unknown int" + let bot_name = "Error int" + end) (Base) + + let top_of ik = top () + let bot_of ik = bot () + + + let name () = "flat integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let starting ?(suppress_ovwarn=false) ikind x = top_of ikind + let ending ?(suppress_ovwarn=false) ikind x = top_of ikind + let maximal x = None + let minimal x = None + + let lift1 f x = match x with + | `Lifted x -> + (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> + (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) +struct + include Lattice.LiftPO (struct + include Printable.DefaultConf + let top_name = "MaxInt" + let bot_name = "MinInt" + end) (Base) + type int_t = Base.int_t + let top_of ik = top () + let bot_of ik = bot () + include StdTop (struct type nonrec t = t let top_of = top_of end) + + let name () = "lifted integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let lift1 f x = match x with + | `Lifted x -> `Lifted (f x) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> `Lifted (f x y) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Flattened = Flat (Integers (IntOps.Int64Ops)) +module Lifted = Lift (Integers (IntOps.Int64Ops)) + +module Reverse (Base: IkindUnawareS) = +struct + include Base + include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) +end + +module BISet = struct + include SetDomain.Make (IntOps.BigIntOps) + let is_singleton s = cardinal s = 1 +end + +(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) +module Exclusion = +struct + module R = Interval32 + (* We use these types for the functions in this module to make the intended meaning more explicit *) + type t = Exc of BISet.t * Interval32.t + type inc = Inc of BISet.t [@@unboxed] + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) + + let cardinality_BISet s = + Z.of_int (BISet.cardinal s) + + let leq_excl_incl (Exc (xs, r)) (Inc ys) = + (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) + let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in + let card_b = cardinality_BISet ys in + if Z.compare lower_bound_cardinality_a card_b > 0 then + false + else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) + let min_a = min_of_range r in + let max_a = max_of_range r in + GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) + + let leq (Exc (xs, r)) (Exc (ys, s)) = + let min_a, max_a = min_of_range r, max_of_range r in + let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) + if not excluded_check + then false + else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) + if R.leq r s then true + else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) + then + let min_b, max_b = min_of_range s, max_of_range s in + let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) + if Z.compare min_a min_b < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) + else + true + in + let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) + if Z.compare max_b max_a < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) + else + true + in + leq1 && (leq2 ()) + else + false + end + end +end + +module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) +struct + module S = BISet + module R = Interval32 (* range for exclusion *) + + (* Ikind used for intervals representing the domain *) + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + + type t = [ + | `Excluded of S.t * R.t + | `Definite of Z.t + | `Bot + ] [@@deriving eq, ord, hash] + type int_t = Z.t + let name () = "def_exc" + + + let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) + let top () = `Excluded (S.empty (), top_range) + let bot () = `Bot + let top_of ik = `Excluded (S.empty (), size ik) + let bot_of ik = bot () + + let show x = + let short_size x = "("^R.show x^")" in + match x with + | `Bot -> "Error int" + | `Definite x -> Z.to_string x + (* Print the empty exclusion as if it was a distinct top element: *) + | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l + (* Prepend the exclusion sets with something: *) + | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let maximal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.max_of_range r) + | `Bot -> None + + let minimal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.min_of_range r) + | `Bot -> None + + let in_range r i = + if Z.compare i Z.zero < 0 then + let lowerb = Exclusion.min_of_range r in + Z.compare lowerb i <= 0 + else + let upperb = Exclusion.max_of_range r in + Z.compare i upperb <= 0 + + let is_top x = x = top () + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Definite x -> if i = x then `Eq else `Neq + | `Excluded (s,r) -> if S.mem i s then `Neq else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function + | `Excluded (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + `Excluded (s, r) + else if ik = IBool then (* downcast to bool *) + if S.mem Z.zero s then + `Definite Z.one + else + `Excluded (S.empty(), r') + else + (* downcast: may overflow *) + (* let s' = S.map (Size.cast ik) s in *) + (* We want to filter out all i in s' where (t)x with x in r could be i. *) + (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) + (* S.diff s' s, r' *) + (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) + `Excluded (S.empty (), r') + | `Definite x -> `Definite (Size.cast ik x) + | `Bot -> `Bot + + (* Wraps definite values and excluded values according to the ikind. + * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. + * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. + *) + let norm ik v = + match v with + | `Excluded (s, r) -> + let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in + (* If no overflow occurred, just return x *) + if not possibly_overflowed then ( + v + ) + (* Else, if an overflow might have occurred but we should just ignore it *) + else if should_ignore_overflow ik then ( + let r = size ik in + (* filter out excluded elements that are not in the range *) + let mapped_excl = S.filter (in_range r) s in + `Excluded (mapped_excl, r) + ) + (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) + else if not (should_wrap ik) then ( + top_of ik + ) else ( + (* Else an overflow occurred that we should treat with wrap-around *) + let r = size ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in + match ik with + | IBool -> + begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with + | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) + | true, false -> `Definite Z.one (* Not {0} -> 1 *) + | false, true -> `Definite Z.zero (* Not {1} -> 0 *) + | true, true -> `Bot (* Not {0, 1} -> bot *) + end + | ik -> + `Excluded (mapped_excl, r) + ) + | `Definite x -> + let min, max = Size.range ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + if should_wrap ik then ( + cast_to ik v + ) + else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( + v + ) + else if should_ignore_overflow ik then ( + M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + `Bot + ) + else ( + top_of ik + ) + | `Bot -> `Bot + + let leq x y = match (x,y) with + (* `Bot <= x is always true *) + | `Bot, _ -> true + (* Anything except bot <= bot is always false *) + | _, `Bot -> false + (* Two known values are leq whenever equal *) + | `Definite (x: int_t), `Definite y -> x = y + (* A definite value is leq all exclusion sets that don't contain it *) + | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) + (* No finite exclusion set can be leq than a definite value *) + | `Excluded (xs, xr), `Definite d -> + Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) + | `Excluded (xs,xr), `Excluded (ys,yr) -> + Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) + + let join' ?range ik x y = + match (x,y) with + (* The least upper bound with the bottom element: *) + | `Bot, x -> x + | x, `Bot -> x + (* The case for two known values: *) + | `Definite (x: int_t), `Definite y -> + (* If they're equal, it's just THAT value *) + if x = y then `Definite x + (* Unless one of them is zero, we can exclude it: *) + else + let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in + `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) + (* A known value and an exclusion set... the definite value should no + * longer be excluded: *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> + if not (in_range r x) then + let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in + `Excluded (S.remove x s, R.join a r) + else + `Excluded (S.remove x s, r) + (* For two exclusion sets, only their intersection can be excluded: *) + | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) + + let join ik = join' ik + + + let widen ik x y = + if get_def_exc_widen_by_join () then + join' ik x y + else if equal x y then + x + else + join' ~range:(size ik) ik x y + + + let meet ik x y = + match (x,y) with + (* Greatest LOWER bound with the least element is trivial: *) + | `Bot, _ -> `Bot + | _, `Bot -> `Bot + (* Definite elements are either equal or the glb is bottom *) + | `Definite x, `Definite y -> if x = y then `Definite x else `Bot + (* The glb of a definite element and an exclusion set is either bottom or + * just the element itself, if it isn't in the exclusion set *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x + (* The greatest lower bound of two exclusion sets is their union, this is + * just DeMorgans Law *) + | `Excluded (x,r1), `Excluded (y,r2) -> + let r' = R.meet r1 r2 in + let s' = S.union x y |> S.filter (in_range r') in + `Excluded (s', r') + + let narrow ik x y = x + + let of_int ik x = norm ik @@ `Definite x + let to_int x = match x with + | `Definite x -> Some x + | _ -> None + + let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) + + let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) + let of_bool = of_bool_cmp + let to_bool x = + match x with + | `Definite x -> Some (IntOps.BigIntOps.to_bool x) + | `Excluded (s,r) when S.mem Z.zero s -> Some true + | _ -> None + let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in + norm ik @@ (`Excluded (ex, r)) + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let of_excl_list t l = + let r = size t in (* elements in l are excluded from the full range of t! *) + `Excluded (List.fold_right S.add l (S.empty ()), r) + let is_excl_list l = match l with `Excluded _ -> true | _ -> false + let to_excl_list (x:t) = match x with + | `Definite _ -> None + | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) + | `Bot -> None + + let to_incl_list x = match x with + | `Definite x -> Some [x] + | `Excluded _ -> None + | `Bot -> None + + let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) + (* If the Int64 might overflow on us during computation, we instead go to top_range *) + match R.minimal r, R.maximal r with + | _ -> + let rf m = (size % Size.min_for % f) (m r) in + let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in + R.join r1 r2 + + (* Default behaviour for unary operators, simply maps the function to the + * DefExc data structure. *) + let lift1 f ik x = norm ik @@ match x with + | `Excluded (s,r) -> + let s' = S.map f s in + `Excluded (s', apply_range f r) + | `Definite x -> `Definite (f x) + | `Bot -> `Bot + + let lift2 f ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite _ + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (f x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + (* Default behaviour for binary operators that are injective in either + * argument, so that Exclusion Sets can be used: *) + let lift2_inj f ik x y = + let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in + norm ik @@ + match x,y with + (* If both are exclusion sets, there isn't anything we can do: *) + | `Excluded _, `Excluded _ -> top () + (* A definite value should be applied to all members of the exclusion set *) + | `Definite x, `Excluded (s,r) -> def_exc f x s r + (* Same thing here, but we should flip the operator to map it properly *) + | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r + (* The good case: *) + | `Definite x, `Definite y -> `Definite (f x y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The equality check: *) + let eq ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x equal to an exclusion set, if it is a member then NO otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x = y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The inequality check: *) + let ne ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x <> y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x + let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y + + let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y + let mul ?no_ov ik x y = norm ik @@ match x, y with + | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x + | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y + | `Definite a, `Excluded (s,r) + (* Integer multiplication with even numbers is not injective. *) + (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) + | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) + | _ -> lift2_inj Z.mul ik x y + let div ?no_ov ik x y = lift2 Z.div ik x y + let rem ik x y = lift2 Z.rem ik x y + + (* Comparison handling copied from Enums. *) + let handle_bot x y f = match x, y with + | `Bot, `Bot -> `Bot + | `Bot, _ + | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> f () + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let lognot = lift1 Z.lognot + + let logand ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite i -> + (* Except in two special cases *) + if Z.equal i Z.zero then + `Definite Z.zero + else if Z.equal i Z.one then + of_interval IBool (Z.zero, Z.one) + else + top () + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + norm ik @@ lift2 shift_op_big_int ik x y + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + (* TODO: lift does not treat Not {0} as true. *) + let c_logand ik x y = + match to_bool x, to_bool y with + | Some false, _ + | _, Some false -> + of_bool ik false + | _, _ -> + lift2 IntOps.BigIntOps.c_logand ik x y + let c_logor ik x y = + match to_bool x, to_bool y with + | Some true, _ + | _, Some true -> + of_bool ik true + | _, _ -> + lift2 IntOps.BigIntOps.c_logor ik x y + let c_lognot ik = eq ik (of_int ik Z.zero) + + let invariant_ikind e ik (x:t) = + match x with + | `Definite x -> + IntInvariant.of_int e ik x + | `Excluded (s, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let si = IntInvariant.of_excl_list e ik (S.elements s) in + Invariant.(ri && si) + | `Bot -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + let excluded s = from_excl ik s in + let definite x = of_int ik x in + let shrink = function + | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) + | `Bot -> empty + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map excluded (S.arbitrary ()); + 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); + 1, QCheck.always `Bot + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = a + let refine_with_interval ik a b = match a, b with + | x, Some(i) -> meet ik x (of_interval ik i) + | _ -> a + let refine_with_excl_list ik a b = match a, b with + | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end + +(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) +module Enums : S with type int_t = Z.t = struct + module R = Interval32 (* range for exclusion *) + + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) + + type int_t = Z.t + let name () = "enums" + let bot () = failwith "bot () not implemented for Enums" + let top () = failwith "top () not implemented for Enums" + let bot_of ik = Inc (BISet.empty ()) + let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) + let top_of ik = + match ik with + | IBool -> top_bool + | _ -> Exc (BISet.empty (), size ik) + + let range ik = Size.range ik + + (* + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) + let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 + + let show = function + | Inc xs when BISet.is_empty xs -> "bot" + | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" + | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + (* Normalization function for enums, that handles overflows for Inc. + As we do not compute on Excl, we do not have to perform any overflow handling for it. *) + let norm ikind v = + let min, max = range ikind in + (* Whether the value v lies within the values of the specified ikind. *) + let value_in_ikind v = + Z.compare min v <= 0 && Z.compare v max <= 0 + in + match v with + | Inc xs when BISet.for_all value_in_ikind xs -> v + | Inc xs -> + if should_wrap ikind then + Inc (BISet.map (Size.cast ikind) xs) + else if should_ignore_overflow ikind then + Inc (BISet.filter value_in_ikind xs) + else + top_of ikind + | Exc (xs, r) -> + (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: + let range_in_ikind r = + R.leq r (size ikind) + in + let r_min, r_max = min_of_range r, max_of_range r in + assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) + begin match ikind with + | IBool -> + begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with + | false, false -> top_bool (* Not {} -> {0, 1} *) + | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) + | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) + | true, true -> bot_of ikind (* Not {0, 1} -> bot *) + end + | _ -> + v + end + + + let equal_to i = function + | Inc x -> + if BISet.mem i x then + if BISet.is_singleton x then `Eq + else `Top + else `Neq + | Exc (x, r) -> + if BISet.mem i x then `Neq + else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with + | Exc (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + Exc (s, r) + else if ik = IBool then (* downcast to bool *) + if BISet.mem Z.zero s then + Inc (BISet.singleton Z.one) + else + Exc (BISet.empty(), r') + else (* downcast: may overflow *) + Exc ((BISet.empty ()), r') + | Inc xs -> + let casted_xs = BISet.map (Size.cast ik) xs in + if Cil.isSigned ik && not (BISet.equal xs casted_xs) + then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) + else Inc casted_xs + + let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) + + let of_interval ?(suppress_ovwarn=false) ik (x, y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in + norm ik @@ (Exc (ex, r)) + + let join _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.union x y) + | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) + | Exc (x,r), Inc y + | Inc y, Exc (x,r) -> + let r = if BISet.is_empty y + then r + else + let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in + let range = R.join min_el_range max_el_range in + R.join r range + in + Exc (BISet.diff x y, r) + + let meet _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.inter x y) + | Exc (x,r1), Exc (y,r2) -> + let r = R.meet r1 r2 in + let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in + let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in + (* We remove those elements from the exclusion set that do not fit in the range anyway *) + let excl = BISet.union (filter_by_range x) (filter_by_range y) in + Exc (excl, r) + | Inc x, Exc (y,r) + | Exc (y,r), Inc x -> Inc (BISet.diff x y) + + let widen = join + let narrow = meet + let leq a b = + match a, b with + | Inc xs, Exc (ys, r) -> + if BISet.is_empty xs + then true + else + let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in + let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in + (* Check that the xs fit into the range r *) + Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && + (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) + BISet.for_all (fun x -> not (BISet.mem x ys)) xs + | Inc xs, Inc ys -> + BISet.subset xs ys + | Exc (xs, r), Exc (ys, s) -> + Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) + | Exc (xs, r), Inc ys -> + Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) + + let handle_bot x y f = match is_bot x, is_bot y with + | false, false -> f () + | true, false + | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | true, true -> Inc (BISet.empty ()) + + let lift1 f ikind v = norm ikind @@ match v with + | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) + | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) + | _ -> top_of ikind + + let lift2 f (ikind: Cil.ikind) u v = + handle_bot u v (fun () -> + norm ikind @@ match u, v with + | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) + | _,_ -> top_of ikind) + + let lift2 f ikind a b = + try lift2 f ikind a b with Division_by_zero -> top_of ikind + + let neg ?no_ov = lift1 Z.neg + let add ?no_ov ikind a b = + match a, b with + | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,y -> lift2 Z.add ikind x y + let sub ?no_ov = lift2 Z.sub + let mul ?no_ov ikind a b = + match a, b with + | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b + | x,y -> lift2 Z.mul ikind x y + + let div ?no_ov ikind a b = match a, b with + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | x,y -> lift2 Z.div ikind x y + + let rem = lift2 Z.rem + + let lognot = lift1 Z.lognot + let logand = lift2 Z.logand + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + handle_bot x y (fun () -> + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + lift2 shift_op_big_int ik x y) + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + + let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) + let to_bool = function + | Inc e when BISet.is_empty e -> None + | Exc (e,_) when BISet.is_empty e -> None + | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false + | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true + | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true + | _ -> None + let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None + + let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None + let of_excl_list ik xs = + let min_ik, max_ik = Size.range ik in + let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in + norm ik @@ Exc (exc, size ik) + let is_excl_list = BatOption.is_some % to_excl_list + let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let c_lognot ik x = + if is_bot x + then x + else + match to_bool x with + | Some b -> of_bool ik (not b) + | None -> top_bool + + let c_logand = lift2 IntOps.BigIntOps.c_logand + let c_logor = lift2 IntOps.BigIntOps.c_logor + let maximal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) + | Exc (excl,r) -> + let rec decrement_while_contained v = + if BISet.mem v excl + then decrement_while_contained (Z.pred v) + else v + in + let range_max = Exclusion.max_of_range r in + Some (decrement_while_contained range_max) + | _ (* bottom case *) -> None + + let minimal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) + | Exc (excl,r) -> + let rec increment_while_contained v = + if BISet.mem v excl + then increment_while_contained (Z.succ v) + else v + in + let range_min = Exclusion.min_of_range r in + Some (increment_while_contained range_min) + | _ (* bottom case *) -> None + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let eq ik x y = + handle_bot x y (fun () -> + match x, y with + | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) + | _, _ -> + if is_bot (meet ik x y) then + (* If the meet is empty, there is no chance that concrete values are equal *) + of_bool ik false + else + top_bool) + + let ne ik x y = c_lognot ik (eq ik x y) + + let invariant_ikind e ik x = + match x with + | Inc ps -> + IntInvariant.of_incl_list e ik (BISet.elements ps) + | Exc (ns, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in + Invariant.(ri && nsi) + + + let arbitrary ik = + let open QCheck.Iter in + let neg s = of_excl_list ik (BISet.elements s) in + let pos s = norm ik (Inc s) in + let shrink = function + | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) + | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map neg (BISet.arbitrary ()); + 10, QCheck.map pos (BISet.arbitrary ()); + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = + let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in + match a, b with + | Inc e, None -> bot_of ik + | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) + | _ -> a + + let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) + + let refine_with_excl_list ik a b = + match b with + | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + + let refine_with_incl_list ik a b = + match a, b with + | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) + | _ -> a + + let project ik p t = t +end + +module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = +struct + let name () = "congruences" + type int_t = Z.t + + (* represents congruence class of c mod m, None is bot *) + type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] + + let ( *: ) = Z.mul + let (+:) = Z.add + let (-:) = Z.sub + let (%:) = Z.rem + let (/:) = Z.div + let (=:) = Z.equal + let (<:) x y = Z.compare x y < 0 + let (>:) x y = Z.compare x y > 0 + let (<=:) x y = Z.compare x y <= 0 + let (>=:) x y = Z.compare x y >= 0 + (* a divides b *) + let ( |: ) a b = + if a =: Z.zero then false else (b %: a) =: Z.zero + + let normalize ik x = + match x with + | None -> None + | Some (c, m) -> + if m =: Z.zero then + if should_wrap ik then + Some (Size.cast ik c, m) + else + Some (c, m) + else + let m' = Z.abs m in + let c' = c %: m' in + if c' <: Z.zero then + Some (c' +: m', m') + else + Some (c' %: m', m') + + let range ik = Size.range ik + + let top () = Some (Z.zero, Z.one) + let top_of ik = Some (Z.zero, Z.one) + let bot () = None + let bot_of ik = bot () + + let show = function ik -> match ik with + | None -> "⟂" + | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c + | Some (c, m) -> + let a = if c =: Z.zero then "" else Z.to_string c in + let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in + let c = if a = "" || b = "" then "" else "+" in + a^c^b + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let is_top x = x = top () + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq + | Some (a, b) -> if i %: b =: a then `Top else `Neq + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero + | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 + (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 + Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) + + let leq x y = + let res = leq x y in + if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; + res + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (c1,m1), Some (c2,m2) -> + let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in + normalize ik (Some (c1, m3)) + + let join ik (x:t) y = + let res = join ik x y in + if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; + res + + + let meet ik x y = + (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) + let congruence_series a c m = + let rec next a1 c1 a2 c2 = + if a2 |: a1 then (a2, c2) + else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) + in next m Z.zero a c + in + let simple_case i c m = + if m |: (i -: c) + then Some (i, Z.zero) else None + in + match x, y with + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 + | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 + | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> + let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in + normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) + | _ -> None + + let meet ik x y = + let res = meet ik x y in + if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; + res + + let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None + let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) + let zero = Some (Z.zero, Z.zero) + let one = Some (Z.one, Z.zero) + let top_bool = top() + + let of_bool _ik = function true -> one | false -> zero + + let to_bool (a: t) = match a with + | None -> None + | x when equal zero x -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = top() + + let ending = starting + + let of_congruence ik (c,m) = normalize ik @@ Some(c,m) + + let maximal t = match t with + | Some (x, y) when y =: Z.zero -> Some x + | _ -> None + + let minimal t = match t with + | Some (x,y) when y =: Z.zero -> Some x + | _ -> None + + (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) + let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = + match x with + | None -> None + | Some (c, m) when m =: Z.zero -> + let c' = Size.cast t c in + (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) + (* We go with GCC behavior here: *) + (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) + (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) + (* Clang behaves the same but they never document that anywhere *) + Some (c', m) + | _ -> + let (min_t, max_t) = range t in + let p ikorg = + let (min_ikorg, max_ikorg) = range ikorg in + ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) + in + match torg with + | Some (Cil.TInt (ikorg, _)) when p ikorg -> + if M.tracing then M.trace "cong-cast" "some case"; + x + | _ -> top () + + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = + let pretty_bool _ x = Pretty.text (string_of_bool x) in + let res = cast_to ?torg ?no_ov t x in + if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; + res + + let widen = join + + let widen ik x y = + let res = widen ik x y in + if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; + res + + let narrow = meet + + let log f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) + let c_logand = log (&&) + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let shift_right _ _ _ = top() + + let shift_right ik x y = + let res = shift_right ik x y in + if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; + res + + let shift_left ik x y = + (* Naive primality test *) + (* let is_prime n = + let n = Z.abs n in + let rec is_prime' d = + (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) + in + not (n =: Z.one) && is_prime' (Z.of_int 2) + in *) + match x, y with + | None, None -> None + | None, _ + | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik + | Some (c, m), Some (c', m') -> + let (_, max_ik) = range ik in + if m =: Z.zero && m' =: Z.zero then + normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) + else + let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) + (* TODO: commented out because fails test with _Bool *) + (* if is_prime (m' +: Z.one) then + normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) + else *) + normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) + + let shift_left ik x y = + let res = shift_left ik x y in + if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; + res + + (* Handle unsigned overflows. + From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. + The congruence modulo b may not persist on an overflow. *) + let handle_overflow ik (c, m) = + if m =: Z.zero then + normalize ik (Some (c, m)) + else + (* Find largest m'=2^k (for some k) such that m is divisible by m' *) + let tz = Z.trailing_zeros m in + let m' = Z.shift_left Z.one tz in + + let max = (snd (Size.range ik)) +: Z.one in + if m' >=: max then + (* if m' >= 2 ^ {bitlength}, there is only one value in range *) + let c' = c %: max in + Some (c', Z.zero) + else + normalize ik (Some (c, m')) + + let mul ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) + in + match x, y with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) when no_ov -> + Some (no_ov_case (c1, m1) (c2, m2)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b ) + | _ -> top () + + let mul ?no_ov ik x y = + let res = mul ?no_ov ik x y in + if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; + res + + let neg ?(no_ov=false) ik x = + match x with + | None -> bot() + | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x + + let add ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 +: c2, Z.gcd m1 m2 + in + match (x, y) with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some a, Some b when no_ov -> + normalize ik (Some (no_ov_case a b)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b) + | _ -> top () + + + let add ?no_ov ik x y = + let res = add ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "add : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) + + + let sub ?no_ov ik x y = + let res = sub ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let lognot ik x = match x with + | None -> None + | Some (c, m) -> + if (Cil.isSigned ik) then + sub ik (neg ik x) one + else + let (_, max_ik) = range ik in + Some (Z.sub max_ik c, m) + + (** The implementation of the bit operations could be improved based on the master’s thesis + 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. + see: http://www.es.mdh.se/pdf_publications/948.pdf *) + let bit2 f ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) + else top () + + let logor ik x y = bit2 Z.logor ik x y + + let logand ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then + (* both arguments constant *) + Some (Z.logand c c', Z.zero) + else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then + (* x & 1 and x == c (mod 2*z) *) + (* Value is equal to LSB of c *) + Some (Z.logand c c', Z.zero) + else + top () + + let logxor ik x y = bit2 Z.logxor ik x y + + let rem ik x y = + match x, y with + | None, None -> bot() + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some(c2, m2) -> + if m2 =: Z.zero then + if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then + Some (c1 %: c2, Z.zero) + else + normalize ik (Some (c1, (Z.gcd m1 c2))) + else + normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) + + let rem ik x y = let res = rem ik x y in + if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; + res + + let div ?(no_ov=false) ik x y = + match x,y with + | None, None -> bot () + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, x when leq zero x -> top () + | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () + | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) + | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) + | _, _ -> top () + + + let div ?no_ov ik x y = + let res = div ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty + res ; + res + + let ne ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) + | x, y -> if meet ik x y = None then of_bool ik true else top_bool + + let eq ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) + | x, y -> if meet ik x y <> None then top_bool else of_bool ik false + + let comparison ik op x y = match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) -> + if m1 =: Z.zero && m2 =: Z.zero then + if op c1 c2 then of_bool ik true else of_bool ik false + else + top_bool + + let ge ik x y = comparison ik (>=:) x y + + let ge ik x y = + let res = ge ik x y in + if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let le ik x y = comparison ik (<=:) x y + + let le ik x y = + let res = le ik x y in + if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let gt ik x y = comparison ik (>:) x y + + + let gt ik x y = + let res = gt ik x y in + if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; + res + + let lt ik x y = comparison ik (<:) x y + + let lt ik x y = + let res = lt ik x y in + if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; + res + + let invariant_ikind e ik x = + match x with + | x when is_top x -> Invariant.top () + | Some (c, m) when m =: Z.zero -> + IntInvariant.of_int e ik c + | Some (c, m) -> + let open Cil in + let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in + Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) + | None -> Invariant.none + + let arbitrary ik = + let open QCheck in + let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in + let cong_arb = pair int_arb int_arb in + let of_pair ik p = normalize ik (Some p) in + let to_pair = Option.get in + set_print show (map ~rev:to_pair (of_pair ik) cong_arb) + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =: Z.zero then + if c <: x || c >: y then None else Some (c, Z.zero) + else + let rcx = x +: ((c -: x) %: Z.abs m) in + let lcy = y -: ((y -: c) %: Z.abs m) in + if rcx >: lcy then None + else if rcx =: lcy then Some (rcx, Z.zero) + else cong + | _ -> None + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = + let pretty_intv _ i = + match i with + | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u + | _ -> Pretty.text ("Display Error") in + let refn = refine_with_interval ik cong intv in + if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; + refn + + let refine_with_congruence ik a b = meet ik a b + let refine_with_excl_list ik a b = a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end + +module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct + + include D + + let lift v = (v, {overflow=false; underflow=false}) + + let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = lift @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = lift @@ D.shift_left ik x y + + let shift_right ik x y = lift @@ D.shift_right ik x y + +end + + + + + + +(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) +(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) +module IntDomTupleImpl = struct + include Printable.Std (* for default invariant, tag, ... *) + + open Batteries + type int_t = Z.t + module I1 = SOverflowLifter (DefExc) + module I2 = Interval + module I3 = SOverflowLifter (Enums) + module I4 = SOverflowLifter (Congruence) + module I5 = IntervalSetFunctor (IntOps.BigIntOps) + module I6 = BitfieldFunctor (IntOps.BigIntOps) + + type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option + [@@deriving eq, ord, hash] + + let name () = "intdomtuple" + + (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) + let no_interval = Tuple6.map2 (const None) + let no_intervalSet = Tuple6.map5 (const None) + + type 'a m = (module SOverflow with type t = 'a) + type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) + + (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) + type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) + type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) + type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) + + type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) + type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) + type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] + type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] + type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] + type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) + let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) + let create r x = (* use where values are introduced *) + create r x (int_precision_from_node_or_config ()) + let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) + let create2 r x = (* use where values are introduced *) + create2 r x (int_precision_from_node_or_config ()) + + let no_overflow ik = function + | Some(_, {underflow; overflow}) -> not (underflow || overflow) + | _ -> false + + let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = + let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in + if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( + let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in + let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in + let underflow = underflow_intv && underflow_intv_set in + let overflow = overflow_intv && overflow_intv_set in + set_overflow_flag ~cast ~underflow ~overflow ik; + ); + no_ov + + let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = + let f b g = if b then Some (g x) else None in + let map x = Option.map fst x in + let intv = f p2 @@ r.fi2_ovc (module I2) in + let intv_set = f p5 @@ r.fi2_ovc (module I5) in + ignore (check_ov ~cast:false ik intv intv_set); + map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) + + let create2_ovc ik r x = (* use where values are introduced *) + create2_ovc ik r x (int_precision_from_node_or_config ()) + + + let opt_map2 f ?no_ov = + curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None + + let to_list x = Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) + let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) + + let exists = function + | (Some true, _, _, _, _,_) + | (_, Some true, _, _, _,_) + | (_, _, Some true, _, _,_) + | (_, _, _, Some true, _,_) + | (_, _, _, _, Some true,_) + | (_, _, _, _, _, Some true) + -> true + | _ -> + false + + let for_all = function + | (Some false, _, _, _, _,_) + | (_, Some false, _, _, _,_) + | (_, _, Some false, _, _,_) + | (_, _, _, Some false, _,_) + | (_, _, _, _, Some false,_) + | (_, _, _, _, _, Some false) + -> + false + | _ -> + true + + (* f0: constructors *) + let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () + let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () + let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } + let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } + let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } + let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} + let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } + let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } + let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } + let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } + let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } + + let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_congruence ik a cong + , opt I2.refine_with_congruence ik b cong + , opt I3.refine_with_congruence ik c cong + , opt I4.refine_with_congruence ik d cong + , opt I5.refine_with_congruence ik e cong + , opt I6.refine_with_congruence ik f cong + ) + + let refine_with_interval ik (a, b, c, d, e,f) intv = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_interval ik a intv + , opt I2.refine_with_interval ik b intv + , opt I3.refine_with_interval ik c intv + , opt I4.refine_with_interval ik d intv + , opt I5.refine_with_interval ik e intv + , opt I6.refine_with_interval ik f intv ) + + let refine_with_excl_list ik (a, b, c, d, e,f) excl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_excl_list ik a excl + , opt I2.refine_with_excl_list ik b excl + , opt I3.refine_with_excl_list ik c excl + , opt I4.refine_with_excl_list ik d excl + , opt I5.refine_with_excl_list ik e excl + , opt I6.refine_with_excl_list ik f excl ) + + let refine_with_incl_list ik (a, b, c, d, e,f) incl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_incl_list ik a incl + , opt I2.refine_with_incl_list ik b incl + , opt I3.refine_with_incl_list ik c incl + , opt I4.refine_with_incl_list ik d incl + , opt I5.refine_with_incl_list ik e incl + , opt I6.refine_with_incl_list ik f incl ) + + + let mapp r (a, b, c, d, e, f) = + let map = BatOption.map in + ( map (r.fp (module I1)) a + , map (r.fp (module I2)) b + , map (r.fp (module I3)) c + , map (r.fp (module I4)) d + , map (r.fp (module I5)) e + , map (r.fp (module I6)) f) + + + let mapp2 r (a, b, c, d, e, f) = + BatOption. + ( map (r.fp2 (module I1)) a + , map (r.fp2 (module I2)) b + , map (r.fp2 (module I3)) c + , map (r.fp2 (module I4)) d + , map (r.fp2 (module I5)) e + , map (r.fp2 (module I6)) f) + + + (* exists/for_all *) + let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } + let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } + let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } + let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } + + let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + ( opt_map2 (r.f2p (module I1)) xa ya + , opt_map2 (r.f2p (module I2)) xb yb + , opt_map2 (r.f2p (module I3)) xc yc + , opt_map2 (r.f2p (module I4)) xd yd + , opt_map2 (r.f2p (module I5)) xe ye + , opt_map2 (r.f2p (module I6)) xf yf) + + (* f2p: binary projections *) + let (%%) f g x = f % (g x) (* composition for binary function g *) + + let leq = + for_all + %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} + + let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) + + let to_excl_list x = + let merge ps = + let (vs, rs) = List.split ps in + let (mins, maxs) = List.split rs in + (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge + + let to_incl_list x = + let hd l = match l with h::t -> h | _ -> [] in + let tl l = match l with h::t -> t | _ -> [] in + let a y = BatSet.of_list (hd y) in + let b y = BatList.map BatSet.of_list (tl y) in + let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge + + let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in + if n = 1 then Some (List.hd xs) + else ( + if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) + None + ) + let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } + + let pretty () x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) + | _ -> + mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x + |> to_list + |> (fun xs -> + text "(" ++ ( + try + List.reduce (fun a b -> a ++ text "," ++ b) xs + with Invalid_argument _ -> + nil) + ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) + + let refine_functions ik : (t -> t) list = + let maybe reffun ik domtup dom = + match dom with Some y -> reffun ik domtup y | _ -> domtup + in + [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e,f) b); (* TODO: get interval across all domains with minimal and maximal *) + (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e,f) d)] + + let refine ik ((a, b, c, d, e,f) : t ) : t = + let dt = ref (a, b, c, d, e,f) in + (match get_refinement () with + | "never" -> () + | "once" -> + List.iter (fun f -> dt := f !dt) (refine_functions ik); + | "fixpoint" -> + let quit_loop = ref false in + while not !quit_loop do + let old_dt = !dt in + List.iter (fun f -> dt := f !dt) (refine_functions ik); + quit_loop := equal old_dt !dt; + if is_bot !dt then dt := bot_of ik; quit_loop := true; + if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; + done; + | _ -> () + ); !dt + + + (* map with overflow check *) + let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = + let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in + let intv = map (r.f1_ovc (module I2)) b in + let intv_set = map (r.f1_ovc (module I5)) e in + let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a + , BatOption.map fst intv + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d + , BatOption.map fst intv_set + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) + + (* map2 with overflow check *) + let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in + let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in + let no_ov = check_ov ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya + , BatOption.map fst intv + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd + , BatOption.map fst intv_set + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) + + let map ik r (a, b, c, d, e, f) = + refine ik + BatOption. + ( map (r.f1 (module I1)) a + , map (r.f1 (module I2)) b + , map (r.f1 (module I3)) c + , map (r.f1 (module I4)) d + , map (r.f1 (module I5)) e + , map (r.f1 (module I6)) f) + + let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + let r = + ( opt_map2 (r.f2 (module I1)) xa ya + , opt_map2 (r.f2 (module I2)) xb yb + , opt_map2 (r.f2 (module I3)) xc yc + , opt_map2 (r.f2 (module I4)) xd yd + , opt_map2 (r.f2 (module I5)) xe ye + , opt_map2 (r.f2 (module I6)) xf yf) + in + if norefine then r else refine ik r + + + (* f1: unary ops *) + let neg ?no_ov ik = + mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} + + let lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} + + let c_lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = + mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} + + (* fp: projections *) + let equal_to i x = + let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple6.enum |> List.of_enum |> List.filter_map identity in + if List.mem `Eq xs then `Eq else + if List.mem `Neq xs then `Neq else + `Top + + let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } + let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } + let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } + (* others *) + let show x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v + | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x + |> to_list + |> String.concat "; " + let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } + + (* `map/opt_map` are used by `project` *) + let opt_map b f = + curry @@ function None, true -> f | x, y when y || b -> x | _ -> None + let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = + ( opt_map keep (r.f3 (module I1)) i1 b1 + , opt_map keep (r.f3 (module I2)) i2 b2 + , opt_map keep (r.f3 (module I3)) i3 b3 + , opt_map keep (r.f3 (module I4)) i4 b4 + , opt_map keep (r.f3 (module I5)) i5 b5 + , opt_map keep (r.f3 (module I6)) i6 b6) + + (** Project tuple t to precision p + * We have to deactivate IntDomains after the refinement, since we might + * lose information if we do it before. E.g. only "Interval" is active + * and shall be projected to only "Def_Exc". By seting "Interval" to None + * before refinement we have no information for "Def_Exc". + * + * Thus we have 3 Steps: + * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element + * 2. Refine the padded t + * 3. Set elements of t to `None` if p is false for this element + * + * Side Note: + * ~keep is used to reuse `map/opt_map` for Step 1 and 3. + * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. + * This way we won't loose any information for the refinement. + * ~keep:false will set the elements to `None` as defined by p *) + let project ik (p: int_precision) t = + let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in + let t_refined = refine ik t_padded in + map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p + + + (* f2: binary ops *) + let join ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} + + let meet ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} + + let widen ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} + + let narrow ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} + + let add ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} + + let sub ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} + + let mul ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} + + let div ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} + + let rem ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} + + let lt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} + + let gt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} + + let le ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} + + let ge ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} + + let eq ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} + + let ne ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} + + let logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} + + let logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} + + let logxor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} + + let shift_left ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} + + let shift_right ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} + + let c_logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} + + let c_logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} + + + (* printing boilerplate *) + let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y + let printXml f x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) + | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) + + let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = + (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) + let simplify_int fallback = + match to_int x with + | Some v -> + (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) + IntInvariant.of_int e ik v + | None -> + fallback () + in + let simplify_all () = + match to_incl_list x with + | Some ps -> + (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) + IntInvariant.of_incl_list e ik ps + | None -> + (* Get interval bounds from all domains (intervals and exclusion set ranges). *) + let min = minimal x in + let max = maximal x in + let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) + (* "Refine" out-of-bounds exclusions for simpler output. *) + let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in + let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in + Invariant.( + IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) + IntInvariant.of_excl_list e ik ns && + Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) + Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) + ) + in + let simplify_none () = + let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in + List.fold_left (fun a i -> + Invariant.(a && i) + ) (Invariant.top ()) is + in + match GobConfig.get_string "ana.base.invariant.int.simplify" with + | "none" -> simplify_none () + | "int" -> simplify_int simplify_none + | "all" -> simplify_int simplify_all + | _ -> assert false + + let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) + + let relift (a, b, c, d, e, f) = + (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) +end + +module IntDomTuple = +struct + module I = IntDomLifter (IntDomTupleImpl) + include I + + let top () = failwith "top in IntDomTuple not supported. Use top_of instead." + let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} + + let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} +end + +let of_const (i, ik, str) = IntDomTuple.of_int ik i From ffc7285760d37911e18de96bfb16804d51756446 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Thu, 14 Nov 2024 20:33:32 +0100 Subject: [PATCH 030/111] refine hotfix2 --- src/cdomain/value/cdomains/intDomain.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 32c86ccf09..53e7e89756 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1533,17 +1533,17 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int M.trace "bitfield" "invariant_ikind"; failwith "Not implemented" - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + let refine_with_congruence ik bf (cong : (int_t * int_t ) option) : t = M.trace "bitfield" "refine_with_congruence"; - t + bf - let refine_with_interval ik a b = + let refine_with_interval ik bf (int: (int_t * int_t) option) : t = M.trace "bitfield" "refine_with_interval"; - t + bf - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + let refine_with_excl_list ik bf (excl : (int_t list * (int64 * int64)) option) : t = M.trace "bitfield" "refine_with_excl_list"; - t + bf let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) From 5ec64ad42b13dead81b2e4bd37da5807eafbe262 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Thu, 14 Nov 2024 20:40:57 +0100 Subject: [PATCH 031/111] restore refine with congruence, as it was lost during merging --- src/cdomain/value/cdomains/intDomain.ml | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 53e7e89756..b68d1d5684 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1533,17 +1533,26 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int M.trace "bitfield" "invariant_ikind"; failwith "Not implemented" - let refine_with_congruence ik bf (cong : (int_t * int_t ) option) : t = - M.trace "bitfield" "refine_with_congruence"; - bf - + let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in + match bf, cong with + | (z,o), Some (c, m) -> + if is_power_of_two m then + let congruenceMask = Ints_t.lognot m in + let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in + let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + norm ik (newz, newo) |> fst + else + top_of ik + | _ -> top_of ik + let refine_with_interval ik bf (int: (int_t * int_t) option) : t = M.trace "bitfield" "refine_with_interval"; - bf + norm ik bf |> fst let refine_with_excl_list ik bf (excl : (int_t list * (int64 * int64)) option) : t = M.trace "bitfield" "refine_with_excl_list"; - bf + norm ik bf |> fst let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) @@ -1552,7 +1561,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | Some ls -> List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls in - BArith.meet t incl_list_masks + let res = BArith.meet t incl_list_masks in + norm ik res |> fst let arbitrary ik = let open QCheck.Iter in From a31dc674d6016917e5208dc8fa75617cd15de411 Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Fri, 15 Nov 2024 18:39:28 +0100 Subject: [PATCH 032/111] intDomain.ml is compilable --- src/cdomain/value/cdomains/intDomain.ml | 47 ++++++++++++------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 1f64aec377..badde25b55 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1190,19 +1190,21 @@ struct end (* Bitfield arithmetic, without any overflow handling etc. *) -module BitFieldArith (Ints_t : IntOps.IntOps) = struct +module BitfieldArith (Ints_t : IntOps.IntOps) = struct + + let of_int x = (Ints_t.lognot x, x) + let one = of_int Ints_t.one let zero = of_int Ints_t.zero - let top_bool = join one zero let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask - - let of_int x = (Ints_t.lognot x, x) let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + let top_bool = join one zero + let is_const (z,o) = (Ints_t.logxor z o) = one_mask let is_undef (z,o) = Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 @@ -1240,7 +1242,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct in aux n 0 in ilog2 (Size.bit ik) - let break_down_log ik (z,o) = if is_undef (z,o) then None + let break_down_log ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_undef (z,o) then None else let n = max_shift ik in let rec break_down c_lst i = if i >= n then c_lst @@ -1253,29 +1255,29 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct else break_down c_lst (i+1) in - let sfx_mask = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in - break_down [(Ints_t.logand z (Ints_t.lognot sfx_msk), Ints_t.logand o sfx_msk)] 0 |> Option.some + let sufx_msk = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in + break_down [(Ints_t.logand z (Ints_t.lognot sufx_msk), Ints_t.logand o sufx_msk)] 0 |> Option.some - let break_down ik bf = Option.map (List.map snd) (break_down_log ik bf) + let break_down ik bf = Option.map (fun c_bf_lst -> List.map snd c_bf_lst |> List.map Ints_t.to_int) (break_down_log ik bf) let shift_right ik bf n_bf = - let shift_right bf (z,o) = - let sign_msk = Ints_t.shift_left one_mask (Size.bit ik - n) in + let shift_right (z,o) c = + let sign_msk = Ints_t.shift_left one_mask (Size.bit ik - c) in if isSigned ik then - (Ints_t.shift_right z n, Ints_t.logor (Ints_t.shift_right o n) sign_msk) + (Ints_t.shift_right z c, Ints_t.logor (Ints_t.shift_right o c) sign_msk) else - (Ints_t.logor (Ints_t.shift_right z n) sign_msk, Ints_t.shift_right o n) + (Ints_t.logor (Ints_t.shift_right z c) sign_msk, Ints_t.shift_right o c) in if is_const n_bf then Some (shift_right bf (Ints_t.to_int @@ snd n_bf)) else Option.map (fun c_lst -> List.map (shift_right bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let shift_left ik bf n_bf = - let shift_left bf (z,o) = - let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one - in (Ints_t.logor (Ints_t.shift_left z n) z_msk, Ints_t.shift_left o n) + let shift_left (z,o) c = + let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one c) Ints_t.one + in (Ints_t.logor (Ints_t.shift_left z c) z_msk, Ints_t.shift_left o c) in - if is_const n then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) + if is_const n_bf then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) @@ -1434,11 +1436,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - norm ik @@ BArith.shift ~left:false ik a b |> Option.value ~default: (bot ()) + norm ik @@ (BArith.shift_right ik a b |> Option.value ~default: (bot ())) let shift_left ik a b = M.trace "bitfield" "shift_left"; - norm ik @@ BArith.shift ~left:true ik a b |> Option.value ~default: (bot ()) + norm ik @@ (BArith.shift_left ik a b |> Option.value ~default: (bot ())) (* Arith *) @@ -1594,16 +1596,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int failwith "Not implemented" let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - M.trace "bitfield" "refine_with_congruence"; - t + M.trace "bitfield" "refine_with_congruence"; bot () let refine_with_interval ik a b = - M.trace "bitfield" "refine_with_interval"; - t + M.trace "bitfield" "refine_with_interval"; bot () let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - M.trace "bitfield" "refine_with_excl_list"; - t + M.trace "bitfield" "refine_with_excl_list"; bot () let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) From 28d9db084a31578ef8dca3f403ef7ccde5b0c6e6 Mon Sep 17 00:00:00 2001 From: ge58kuc Date: Sun, 17 Nov 2024 00:38:28 +0100 Subject: [PATCH 033/111] Avoiding unnecessary computation when min{b} > ceil(log2 max{a}) in shift a b since in that case shift a b = zero always. --- src/cdomain/value/cdomains/intDomain.ml | 89 +++++++++++++------------ 1 file changed, 45 insertions(+), 44 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index badde25b55..5fdb29350e 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1205,8 +1205,13 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let top_bool = join one zero + let bits_known (z,o) = Ints_t.logxor z o + let bits_unknown bf = Ints_t.lognot @@ known_bits bf + let bits_set bf = Ints_t.logand (snd bf) @@ known_bits bf + let bits_undef (z,o) = Ints_t.lognot (Ints_t.logxor z o) + let is_const (z,o) = (Ints_t.logxor z o) = one_mask - let is_undef (z,o) = Ints_t.compare (Ints_t.lognot @@ Ints_t.logor z o) Ints_t.zero = 0 + let is_undef (z,o) = Ints_t.compare (bits_undef (z,o)) Ints_t.zero != 0 let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) @@ -1225,16 +1230,19 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) + let make_bitone_msk pos = Ints_t.shift_left one pos + let make_bitzero_msk pos = Ints_t.lognot @@ make_bitone_msk pos + let make_lsb_bitmask pos = Ints_t.sub (make_bitone_msk pos) Ints_t.one + let make_msb_bitmask pos = Ints_t.lognot @@ make_lsb_bitmask pos + let get_bit bf pos = Ints_t.logand Ints_t.one @@ Ints_t.shift_right bf (pos-1) let set_bit ?(zero=false) bf pos = - let one_mask = Ints_t.shift_left Ints_t.one pos in if zero then - let zero_mask = Ints_t.lognot one_mask in - Ints_t.logand bf zero_mask + Ints_t.logand bf @@ make_bitzero_msk pos else - Ints_t.logor bf one_mask + Ints_t.logor bf @@ make_bitone_msk pos - let max_shift ik = + let log2_bitcnt ik = let ilog2 n = let rec aux n acc = if n <= 1 then acc @@ -1242,23 +1250,27 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in aux n 0 in ilog2 (Size.bit ik) - let break_down_log ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_undef (z,o) then None + let break_down_lsb ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_undef (z,o) then None else - let n = max_shift ik in - let rec break_down c_lst i = if i >= n then c_lst + let rec break_down c_lst i = if i < 0 then c_lst else if get_bit z i = get_bit o i then List.fold_left2 ( fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc ) [] c_lst c_lst - |> fun c_lst -> break_down c_lst (i+1) + |> fun c_lst -> break_down c_lst (i-1) else - break_down c_lst (i+1) + break_down c_lst (i-1) in - let sufx_msk = Ints_t.lognot @@ Ints_t.sub (Ints_t.shift_left Ints_t.one n) Ints_t.one in - break_down [(Ints_t.logand z (Ints_t.lognot sufx_msk), Ints_t.logand o sufx_msk)] 0 |> Option.some + let lsb_bitcnt_log_ik = log2_bitcnt ik + 1 in (* ilog2 bitcnt of ik ceiled *) + let pfx_msk = make_msb_bitmask lsb_bitcnt_log_ik in + let sufx_msk = make_lsb_bitmask lsb_bitcnt_log_ik in + let msb_msk = Ints_t.logand (bits_set (z,o)) pfx_msk in (* shift a b = zero when min{b} > ceil(ilog2 a) *) + if Ints_t.compare msb_msk Ints_t.zero = 0 + then break_down [(Ints_t.logand z pfx_msk, Ints_t.logand o sufx_msk)] (lsb_bitcnt_log_ik - 1) |> Option.some + else Some ([of_int @@ Ints_t.of_int (lsb_bitcnt_log_ik)]) - let break_down ik bf = Option.map (fun c_bf_lst -> List.map snd c_bf_lst |> List.map Ints_t.to_int) (break_down_log ik bf) + let break_down ik bf = Option.map (fun c_bf_lst -> List.map snd c_bf_lst |> List.map Ints_t.to_int) (break_down_lsb ik bf) let shift_right ik bf n_bf = let shift_right (z,o) c = @@ -1267,55 +1279,46 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct (Ints_t.shift_right z c, Ints_t.logor (Ints_t.shift_right o c) sign_msk) else (Ints_t.logor (Ints_t.shift_right z c) sign_msk, Ints_t.shift_right o c) - in + in if is_const n_bf then Some (shift_right bf (Ints_t.to_int @@ snd n_bf)) - else - Option.map (fun c_lst -> List.map (shift_right bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) + else Option.map (fun c_lst -> List.map (shift_right bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let shift_left ik bf n_bf = let shift_left (z,o) c = - let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one c) Ints_t.one - in (Ints_t.logor (Ints_t.shift_left z c) z_msk, Ints_t.shift_left o c) - in + let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one c) Ints_t.one in + (Ints_t.logor (Ints_t.shift_left z c) z_msk, Ints_t.shift_left o c) + in if is_const n_bf then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) - else - Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) - + else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let min ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in + let unknownBitMask = bits_unknown (z,o) in + let impossibleBitMask = bits_undef in + let guaranteedBits = bits_set (z,o) in + if impossibleBitMask <> zero_mask then failwith "Impossible bitfield" else if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let signBitMask = make_bitone_msk (Size.bit ik - 1) in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + Size.cast ik (Ints_t.to_bigint guaranteedBits) let max ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in + let unknownBitMask = bits_unknown (z,o) in + let impossibleBitMask = bits_undef (z,o) in + let guaranteedBits = bits_set (z,o) in if impossibleBitMask <> zero_mask then failwith "Impossible bitfield" else let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - - if isSigned ik then - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in (* Necessary? *) + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) end @@ -1332,8 +1335,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let range ik bf = (BArith.min ik bf, BArith.max ik bf) - let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) - let norm ?(suppress_ovwarn=false) ik (z,o) = let (min_ik, max_ik) = Size.range ik in @@ -1343,8 +1344,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let new_bitfield= (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit z (Size.bit ik))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik))) in (newz,newo) else let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in From 6177b1327ed21c8a3efb11663a4c1648a4e8a188 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Mon, 18 Nov 2024 19:54:19 +0100 Subject: [PATCH 034/111] begin first unit tests --- src/cdomain/value/cdomains/intDomain.ml | 75 ++--- src/cdomain/value/cdomains/intDomain.mli | 4 + tests/regression/01-cpa/76-bitfield.c | 1 + tests/unit/cdomains/intDomainTest.ml | 412 +++++++++++++++++++++++ 4 files changed, 442 insertions(+), 50 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index b68d1d5684..3bcff02413 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1200,8 +1200,6 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct let is_constant (z,o) = (Ints_t.logxor z o) = one_mask - let eq (z1,o1) (z2,o2) = (Ints_t.equal z1 z2) && (Ints_t.equal o1 o2) - let nabla x y= if x = Ints_t.logor x y then x else one_mask let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) @@ -1258,7 +1256,7 @@ module BitFieldArith (Ints_t : IntOps.IntOps) = struct end -module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct +module BitFieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct let name () = "bitfield" type int_t = Ints_t.t type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] @@ -1312,8 +1310,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let leq (x:t) (y:t) = (BArith.join x y) = y let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = y - + let narrow ik x y = x + let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) let to_int (z,o) = if is_bot (z,o) then None else @@ -1328,20 +1326,19 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_interval ?(suppress_ovwarn=false) ik (x,y) = (* naive implentation -> horrible O(n) runtime *) let (min_ik, max_ik) = Size.range ik in - let result = ref (bot ()) in let current = ref (min_ik) in let bf = ref (bot ()) in while Z.leq !current max_ik do bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); current := Z.add !current Z.one done; - norm ~suppress_ovwarn ik !result + norm ~suppress_ovwarn ik !bf let of_bool _ik = function true -> BArith.one | false -> BArith.zero let to_bool d = if not (leq BArith.zero d) then Some true - else if BArith.eq d BArith.zero then Some false + else if d = BArith.zero then Some false else None let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t @@ -1461,32 +1458,28 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int fst (sub ik x tmp)) else top_of ik - let eq ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (BArith.eq x y) - else if not (leq x y || leq y x) then of_bool ik false + let eq ik x y = + if (BArith.max ik x) <= (BArith.min ik y) && (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true + else if (BArith.min ik x) > (BArith.max ik y) || (BArith.max ik x) < (BArith.min ik y) then of_bool ik false else BArith.top_bool - let ne ik x y = - if BArith.is_constant x && BArith.is_constant y then of_bool ik (not (BArith.eq x y)) - else if not (leq x y || leq y x) then of_bool ik true - else BArith.top_bool + let ne ik x y = match eq ik x y with + | t when t = of_bool ik true -> of_bool ik false + | t when t = of_bool ik false -> of_bool ik true + | _ -> BArith.top_bool - let ge ik x y = if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true - else if (BArith.max ik x) < (BArith.min ik y) then of_bool ik false - else BArith.top_bool - - let le ik x y = if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true + let le ik x y = + if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false else BArith.top_bool - let gt ik x y = if (BArith.min ik x) > (BArith.max ik y) then of_bool ik true - else if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik false - else BArith.top_bool + let ge ik x y = le ik y x let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false else BArith.top_bool + let gt ik x y = lt ik y x let invariant_ikind e ik (z,o) = let range = range ik (z,o) in @@ -1512,19 +1505,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else (norm ~suppress_ovwarn ik @@ (top ())) - let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in - match intv, cong with - | (z,o), Some (c, m) -> - if is_power_of_two m then - let congruenceMask = Ints_t.lognot m in - let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in - let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - (newz, newo) - else - top_of ik - | _ -> top_of ik - let refine_with_interval ik t i = t let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t @@ -1536,15 +1516,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in match bf, cong with - | (z,o), Some (c, m) -> - if is_power_of_two m then + | (z,o), Some (c, m) when is_power_of_two m -> let congruenceMask = Ints_t.lognot m in let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in norm ik (newz, newo) |> fst - else - top_of ik - | _ -> top_of ik + | _ -> norm ik bf |> fst let refine_with_interval ik bf (int: (int_t * int_t) option) : t = M.trace "bitfield" "refine_with_interval"; @@ -1555,14 +1532,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik bf |> fst let refine_with_incl_list ik t (incl : (int_t list) option) : t = - (* loop over all included ints *) - let incl_list_masks = match incl with - | None -> t + let joined =match incl with + | None -> top_of ik | Some ls -> - List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls - in - let res = BArith.meet t incl_list_masks in - norm ik res |> fst + List.fold_left (fun acc i -> BArith.join acc (BArith.of_int i)) (bot_of ik) ls + in + meet ik t joined let arbitrary ik = let open QCheck.Iter in @@ -2143,7 +2118,7 @@ end module IntIkind = struct let ikind () = Cil.IInt end module Interval = IntervalFunctor (IntOps.BigIntOps) -module Bitfield = BitfieldFunctor (IntOps.BigIntOps) +module BitField = BitFieldFunctor (IntOps.BigIntOps) module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) @@ -3817,7 +3792,7 @@ module IntDomTupleImpl = struct module I3 = SOverflowLifter (Enums) module I4 = SOverflowLifter (Congruence) module I5 = IntervalSetFunctor (IntOps.BigIntOps) - module I6 = BitfieldFunctor (IntOps.BigIntOps) + module I6 = BitFieldFunctor (IntOps.BigIntOps) type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option [@@deriving eq, ord, hash] diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index e7667c9b14..3c7fb21c23 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -402,12 +402,16 @@ module Lifted : IkindUnawareS with type t = [`Top | `Lifted of int64 | `Bot] and module IntervalFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option +module BitFieldFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) + module IntervalSetFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) option and *) type int_t = IntOps.Int64Ops.t module Interval : SOverflow with type int_t = Z.t +module BitField : SOverflow with type int_t = Z.t + module IntervalSet : SOverflow with type int_t = Z.t module Congruence : S with type int_t = Z.t diff --git a/tests/regression/01-cpa/76-bitfield.c b/tests/regression/01-cpa/76-bitfield.c index 0054f00ee4..2125895d18 100644 --- a/tests/regression/01-cpa/76-bitfield.c +++ b/tests/regression/01-cpa/76-bitfield.c @@ -1,3 +1,4 @@ +//PARAM: --enable ana.int.bitfield #include #include #include diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index a60b7a6cb1..25087069a9 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -250,7 +250,418 @@ struct ] end +module BitFieldTest (I : IntDomain.SOverflow with type int_t = Z.t) = +struct +module I = IntDomain.SOverflowUnlifter (I) + + let ik = Cil.IInt + + let assert_equal x y = + OUnit.assert_equal ~printer:I.show x y + + + let test_of_int_to_int _ = + let b1 = I.of_int ik (of_int 17) in + OUnit.assert_equal 17 (I.to_int b1 |> Option.get |> to_int) + + let test_to_int_of_int _ = + OUnit.assert_equal None (I.to_int (I.bot_of ik)); + OUnit.assert_equal (of_int 13) (I.to_int (I.of_int ik (of_int 13)) |> Option.get); + OUnit.assert_equal None (I.to_int (I.top_of ik)); + OUnit.assert_equal None (I.to_int (I.join ik (I.of_int ik (of_int 13)) (I.of_int ik (of_int 14)))) + + let test_equal_to _ = + let b1 = I.join ik (I.of_int ik (of_int 4)) (I.of_int ik (of_int 2)) in + OUnit.assert_equal `Top (I.equal_to (Z.of_int 4) b1); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 2) b1); + + OUnit.assert_equal `Top (I.equal_to (Z.of_int 0) b1); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 6) b1); + + OUnit.assert_equal `Neq (I.equal_to (Z.of_int 1) b1); + OUnit.assert_equal `Neq (I.equal_to (Z.of_int 3) b1); + OUnit.assert_equal `Neq (I.equal_to (Z.of_int 5) b1); + + let b2 =I.of_int ik (of_int 123) in + OUnit.assert_equal `Eq (I.equal_to (Z.of_int 123) b2) + + let test_join _ = + let b1 = I.of_int ik (of_int 9) in + let b2 = I.of_int ik (of_int 2) in + let bjoin = I.join ik b1 b2 in + assert_bool "num1 leq join" (I.leq b1 bjoin); + assert_bool "num2 leq join" (I.leq b2 bjoin); + + + OUnit.assert_equal `Top (I.equal_to (Z.of_int 9) bjoin); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 2) bjoin); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 11) bjoin) + + let test_meet _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 3) in + let bf12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 7) in + let b4 = I.of_int ik (of_int 4) in + let bf34 = I.join ik b3 b4 in + + let bmeet2 = I.meet ik bf12 bf34 in + + OUnit.assert_equal `Top (I.equal_to (Z.of_int 5) bmeet2); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 7) bmeet2) + + let test_leq_1 _ = + let b1 = I.of_int ik (of_int 13) in + let b2 = I.of_int ik (of_int 5) in + + let bjoin = I.join ik b1 b2 in + + OUnit.assert_bool "13 leq 13" (I.leq b1 b1); + OUnit.assert_bool "5 leq 5" (I.leq b2 b2); + + OUnit.assert_bool "5 leq 13" (I.leq b2 bjoin); + OUnit.assert_bool "not 13 leq 5" (not (I.leq bjoin b2)) + + let test_leq_2 _ = + let b1 = I.of_int ik (of_int 7) in + + OUnit.assert_bool "bot leq 7" (I.leq (I.bot_of ik) b1); + OUnit.assert_bool "7 leq top" (I.leq b1 (I.top_of ik)) + + let test_wrap_1 _ = + let z = of_int 31376 in + let b_uint8 = I.of_int IChar z in + let b_sint8 = I.of_int ISChar z in + let b_uint16 = I.of_int IUShort z in + let b_sint16 = I.of_int IShort z in + + (* See https://www.simonv.fr/TypesConvert/?integers *) + assert_equal (I.of_int IChar (of_int 144)) b_uint8; + assert_equal (I.of_int ISChar (of_int (-112))) b_sint8; + assert_equal (I.of_int IUShort (of_int 31376)) b_uint16; + assert_equal (I.of_int IShort (of_int 31376)) b_sint16 + + let test_wrap_2 _ = + let z1 = of_int 30867 in + let z2 = of_int 30870 in + let join_cast_unsigned = I.join IChar (I.of_int IChar z1) (I.of_int IChar z2) in + + let expected_unsigned = I.join IChar (I.of_int IChar (of_int 147)) (I.of_int IChar (of_int 150)) in + + let expected_signed = I.join IChar (I.of_int IChar (of_int (-106))) (I.of_int IChar (of_int (-109))) in + + assert_equal expected_unsigned join_cast_unsigned; + assert_equal expected_signed join_cast_unsigned + + let test_widen_1 _ = + let b1 = I.of_int ik (of_int 3) in + let b2 = I.of_int ik (of_int 17) in + + (* widen both masks *) + assert_equal (I.top_of ik) (I.widen ik b1 b2); + + (* no widening *) + let bjoin = I.join ik b1 b2 in + assert_equal bjoin (I.widen ik bjoin b1) + + + let test_widen_2 _ = + let b1 = I.of_int ik (of_int 123613) in + let b2 = I.of_int ik (of_int 613261) in + + (* no widening needed *) + assert_bool "join leq widen" (I.leq (I.join ik b1 b2) (I.widen ik b1 b2)) + + let test_of_interval _ = + let intvl= (of_int 3, of_int 17) in + let b1 = I.of_interval ik intvl in + + for i = 3 to 17 do + assert_bool (string_of_int i) (I.equal_to (of_int i) b1 = `Top) + done + + let test_of_bool _ = + let b1 = I.of_bool ik true in + let b2 = I.of_bool ik false in + + assert_bool "true" (I.equal_to (of_int 1) b1 = `Eq); + assert_bool "false" (I.equal_to (of_int 0) b2 = `Eq) + + let test_to_bool _ = + let b1 = I.of_int ik (of_int 3) in + let b2 = I.of_int ik (of_int (-6)) in + let b3 = I.of_int ik (of_int 0) in + + let b12 = I.join ik b1 b2 in + let b13 = I.join ik b1 b3 in + let b23 = I.join ik b2 b3 in + + assert_bool "3" (I.to_bool b1 = Some true); + assert_bool "-6" (I.to_bool b2 = Some true); + assert_bool "0" (I.to_bool b3 = Some false); + + assert_bool "3 | -6" (I.to_bool b12 = Some true); + assert_bool "3 | 0" (I.to_bool b13 = None); + assert_bool "-6 | 0" (I.to_bool b23 = None) + + let test_cast_to _ = + let b1 = I.of_int ik (of_int 1234) in + + assert_equal (I.of_int IChar (of_int (210))) (I.cast_to IChar b1); + assert_equal (I.of_int ISChar (of_int (-46))) (I.cast_to ISChar b1); + + assert_equal (I.of_int IUInt128 (of_int 1234)) (I.cast_to IUInt128 b1) + + (* Bitwise *) + + let test_logxor _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_equal (I.of_int ik (of_int 20)) (I.logxor ik b1 b2); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 13) in + assert_bool "8 ?= 13 xor (5 | 17)" (I.equal_to (of_int 8) (I.logxor ik b12 b3) = `Top); + assert_bool "28 ?= 13 xor (5 | 17)" (I.equal_to (of_int 28) (I.logxor ik b12 b3) = `Top) + + let test_logand _ = + let b1 = I.of_int ik (of_int 7) in + let b2 = I.of_int ik (of_int 13) in + + assert_equal (I.of_int ik (of_int 5)) (I.logand ik b1 b2); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 12) in + assert_bool "4 ?= 12 and (7 | 12)" (I.equal_to (of_int 4) (I.logand ik b12 b3) = `Top); + assert_bool "12 ?= 12 and (7 | 12)" (I.equal_to (of_int 12) (I.logand ik b12 b3) = `Top) + + + let test_logor _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_equal (I.of_int ik (of_int 21)) (I.logor ik b1 b2); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 13) in + assert_bool "13 ?= 13 or (5 | 17)" (I.equal_to (of_int 13) (I.logor ik b12 b3) = `Top); + assert_bool "29 ?= 13 or (5 | 17)" (I.equal_to (of_int 29) (I.logor ik b12 b3) = `Top) + + let test_lognot _ = + let b1 = I.of_int ik (of_int 4) in + let b2 = I.of_int ik (of_int 12) in + + (* assumes two's complement *) + assert_equal (I.of_int ik (of_int (-5))) (I.lognot ik b1); + + let b12= I.join ik b1 b2 in + assert_bool "-13 ?= not (4 | 12)" (I.equal_to (of_int (-13)) (I.lognot ik b12) = `Top); + assert_bool "-5 ?= not (4 | 12)" (I.equal_to (of_int (-5)) (I.lognot ik b12) = `Top) + + let test_shift_left _ = + () + + let test_shift_right _ = + () + + (* Arith *) + + + (* Comparisons *) + + let test_eq _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_bool "5 == 5" (I.eq ik b1 b1 = I.of_bool ik true); + assert_bool "5 == 17" (I.eq ik b1 b2 = I.of_bool ik false); + + let b12 = I.join ik b1 b2 in + assert_bool "5 == (5 | 17)" (I.eq ik b1 b12 = (I.join ik (I.of_bool ik true) (I.of_bool ik false))) + + let test_ne _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_bool "5 != 5" (I.ne ik b1 b1 = I.of_bool ik false); + assert_bool "5 != 17" (I.ne ik b1 b2 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + assert_bool "5 != (5 | 17)" (I.ne ik b1 b12 = (I.join ik (I.of_bool ik false) (I.of_bool ik true))) + + let test_le _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 14) in + + assert_bool "5 <= 5" (I.le ik b1 b1 = I.of_bool ik true); + assert_bool "5 <= 14" (I.le ik b1 b2 = I.of_bool ik true); + assert_bool "14 <= 5" (I.le ik b2 b1 = I.of_bool ik false); + + let b12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 17) in + assert_bool "17 <= (5 | 14)" (I.le ik b3 b12 = I.of_bool ik false); + + let b4 = I.of_int ik (of_int 13) in + assert_bool "13 <= (5 | 14)" (I.le ik b4 b12 = (I.join ik (I.of_bool ik false) (I.of_bool ik true))); + + let b5 = I.of_int ik (of_int 5) in + assert_bool "5 <= (5 | 14)" (I.le ik b5 b12 = I.join ik (I.of_bool ik true) (I.of_bool ik false)); + + let b6 = I.of_int ik (of_int 4) in + assert_bool "4 <= (5 | 14)" (I.le ik b6 b12 = I.of_bool ik true) + + + let test_ge _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 14) in + + assert_bool "5 >= 5" (I.ge ik b1 b1 = I.of_bool ik true); + assert_bool "5 >= 14" (I.ge ik b1 b2 = I.of_bool ik false); + assert_bool "14 >= 5" (I.ge ik b2 b1 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 2) in + assert_bool "2 >= (5 | 14)" (I.ge ik b3 b12 = I.of_bool ik false); + + let b4 = I.of_int ik (of_int 13) in + assert_bool "13 >= (5 | 14)" (I.ge ik b4 b12 = (I.join ik (I.of_bool ik true) (I.of_bool ik false))); + + let b6 = I.of_int ik (of_int 15) in + assert_bool "15 >= (5 | 14)" (I.ge ik b6 b12 = I.of_bool ik true) + + let test_lt _ = + let b1 = I.of_int ik (of_int 7) in + let b2 = I.of_int ik (of_int 13) in + + assert_bool "7 < 7" (I.lt ik b1 b1 = I.of_bool ik false); + assert_bool "7 < 13" (I.lt ik b1 b2 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 4) in + assert_bool "4 < (7 | 13)" (I.lt ik b3 b12 = I.of_bool ik true); + + let b4 = I.of_int ik (of_int 8) in + assert_bool "8 < (7 | 13)" (I.lt ik b4 b12 = I.join ik (I.of_bool ik false) (I.of_bool ik true)) + + let test_gt _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 14) in + + + assert_bool "5 > 5" (I.gt ik b1 b1 = I.of_bool ik false); + assert_bool "5 > 14" (I.gt ik b1 b2 = I.of_bool ik false); + assert_bool "14 > 5" (I.gt ik b2 b1 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 2) in + assert_bool "2 > (5 | 14)" (I.gt ik b3 b12 = I.of_bool ik false); + + let b4 = I.of_int ik (of_int 13) in + assert_bool "13 > (5 | 14)" (I.gt ik b4 b12 = (I.join ik (I.of_bool ik false) (I.of_bool ik true))); + + let b5 = I.of_int ik (of_int 5) in + assert_bool "5 > (5 | 14)" (I.gt ik b5 b12 = I.join ik (I.of_bool ik false) (I.of_bool ik true)); + + let b6 = I.of_int ik (of_int 4) in + assert_bool "4 > (5 | 14)" (I.gt ik b6 b12 = (I.of_bool ik false) ) + + let test_starting _ = + let bf1 = I.starting ik (of_int 17) in + + assert_bool "17" (I.equal_to (of_int 17) bf1 = `Top); + assert_bool "18" (I.equal_to (of_int 18) bf1 = `Top); + + assert_bool "-3" (I.equal_to (of_int (-3)) bf1 = `Neq); + + let bf2 = I.starting ik (of_int (-17)) in + + assert_bool "-16" (I.equal_to (of_int (-16)) bf2 = `Top); + assert_bool "-17" (I.equal_to (of_int (-17)) bf2 = `Top) + + + let test_ending _ = + let bf = I.ending ik (of_int 17) in + + assert_bool "-4" (I.equal_to (of_int (-4)) bf = `Top); + assert_bool "16" (I.equal_to (of_int 16) bf = `Top); + + let bf2 = I.ending ik (of_int (-17)) in + + assert_bool "-16" (I.equal_to (of_int (-16)) bf2 = `Top); + assert_bool "-18" (I.equal_to (of_int (-18)) bf2 = `Top); + + assert_bool "17" (I.equal_to (of_int 17) bf2 = `Neq) + + let test_refine_with_congruence _ = + let bf = I.top_of ik in + + let bf_refined1= I.refine_with_congruence ik bf (Some (Z.of_int 3, Z.of_int 4)) in + assert_bool "3" (I.equal_to (of_int 3) bf_refined1 = `Top); + let bf_refined2= I.refine_with_congruence ik bf_refined1 (Some (Z.of_int 1, Z.of_int 1)) in + assert_bool "1" (I.equal_to (of_int 1) bf_refined2 = `Eq); + let bf_refined3= I.refine_with_congruence ik bf_refined2 (Some (Z.of_int 5, Z.of_int 0)) in + assert_bool "5" (I.equal_to (of_int 5) bf_refined3 = `Eq) + + let test_refine_with_inclusion_list _ = + let bf = I.top_of ik in + + let list = List.map of_int [-2;3;23; 26] in + let bf_refined = I.refine_with_incl_list ik bf (Some list) in + + List.iter (fun i -> assert_bool (Z.to_string i) (I.equal_to i bf_refined = `Top)) list + + let test () =[ + "test_of_int_to_int" >:: test_of_int_to_int; + "test_to_int_of_int" >:: test_to_int_of_int; + "test_equal_to" >:: test_equal_to; + + "test_join" >:: test_join; + "test_meet" >:: test_meet; + + "test_leq_1" >:: test_leq_1; + "test_leq_2" >:: test_leq_2; + + "test_wrap_1" >:: test_wrap_1; + "test_wrap_2" >:: test_wrap_2; + + "test_widen_1" >:: test_widen_1; + "test_widen_2" >:: test_widen_2; + + "test_of_interval" >:: test_of_interval; + "test_of_bool" >:: test_of_bool; + "test_to_bool" >:: test_to_bool; + "test_cast_to" >:: test_cast_to; + + "test_logxor" >:: test_logxor; + "test_logand" >:: test_logand; + "test_logor" >:: test_logor; + "test_lognot" >:: test_lognot; + "test_shift_left" >:: test_shift_left; + "test_shift_right" >:: test_shift_right; + + "test_eq" >:: test_eq; + "test_ne" >:: test_ne; + "test_le" >:: test_le; + "test_ge" >:: test_ge; + "test_lt" >:: test_lt; + "test_gt" >:: test_gt; + + "test_starting" >:: test_starting; + "test_ending" >:: test_ending; + + "test_refine_with_congruence" >:: test_refine_with_congruence; + "test_refine_with_inclusion_list" >:: test_refine_with_inclusion_list; + ] + +end + module Interval = IntervalTest (IntDomain.Interval) +module BitField = BitFieldTest (IntDomain.BitField) module IntervalSet = IntervalTest (IntDomain.IntervalSet) module Congruence = @@ -330,6 +741,7 @@ let test () = "test_meet" >:: test_meet; "test_excl_list">:: test_ex_set; "interval" >::: Interval.test (); + "bitField" >::: BitField.test (); "intervalSet" >::: IntervalSet.test (); "congruence" >::: Congruence.test (); "intDomTuple" >::: IntDomTuple.test (); From 8e8b9cba7e4f4aee5deb9634fe4838d154074b29 Mon Sep 17 00:00:00 2001 From: leon Date: Mon, 18 Nov 2024 23:48:28 +0100 Subject: [PATCH 035/111] add simple shift unit tests --- tests/unit/cdomains/intDomainTest.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 25087069a9..0a9a8dfd97 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -461,10 +461,18 @@ module I = IntDomain.SOverflowUnlifter (I) assert_bool "-5 ?= not (4 | 12)" (I.equal_to (of_int (-5)) (I.lognot ik b12) = `Top) let test_shift_left _ = - () + let stat1 = I.of_int ik (of_int 2) in + let stat2 = I.of_int ik (of_int 1) in + + assert_bool "2 << 1 = 4" (I.equal_to (of_int (4)) (I.shift_left ik stat1 stat2) = `Top) + let test_shift_right _ = - () + let stat1 = I.of_int ik (of_int 4) in + let stat2 = I.of_int ik (of_int 1) in + + assert_bool "4 >> 1 = 2" (I.equal_to (of_int (2)) (I.shift_left ik stat1 stat2) = `Top) + (* Arith *) From 9ae2b8f65d2266be3f60483927204525bf916785 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 19 Nov 2024 12:01:19 +0100 Subject: [PATCH 036/111] base test impl --- src/cdomain/value/cdomains/intDomain.ml | 8 +- src/cdomain/value/cdomains/intDomain.mli | 4 + tests/unit/cdomains/intDomainTest.ml | 420 +++++++++++++++++++++++ 3 files changed, 428 insertions(+), 4 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 87ee6df60f..2bd88836d8 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1206,8 +1206,8 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let top_bool = join one zero let bits_known (z,o) = Ints_t.logxor z o - let bits_unknown bf = Ints_t.lognot @@ known_bits bf - let bits_set bf = Ints_t.logand (snd bf) @@ known_bits bf + let bits_unknown bf = Ints_t.lognot @@ bits_known bf + let bits_set bf = Ints_t.logand (snd bf) @@ bits_known bf let bits_undef (z,o) = Ints_t.lognot (Ints_t.logxor z o) let is_const (z,o) = (Ints_t.logxor z o) = one_mask @@ -1230,7 +1230,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - let make_bitone_msk pos = Ints_t.shift_left one pos + let make_bitone_msk pos = Ints_t.shift_left Ints_t.one pos let make_bitzero_msk pos = Ints_t.lognot @@ make_bitone_msk pos let make_lsb_bitmask pos = Ints_t.sub (make_bitone_msk pos) Ints_t.one let make_msb_bitmask pos = Ints_t.lognot @@ make_lsb_bitmask pos @@ -1293,7 +1293,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let min ik (z,o) = let unknownBitMask = bits_unknown (z,o) in - let impossibleBitMask = bits_undef in + let impossibleBitMask = bits_undef (z,o) in let guaranteedBits = bits_set (z,o) in if impossibleBitMask <> zero_mask then diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index e7667c9b14..3c7fb21c23 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -402,12 +402,16 @@ module Lifted : IkindUnawareS with type t = [`Top | `Lifted of int64 | `Bot] and module IntervalFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option +module BitFieldFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) + module IntervalSetFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) option and *) type int_t = IntOps.Int64Ops.t module Interval : SOverflow with type int_t = Z.t +module BitField : SOverflow with type int_t = Z.t + module IntervalSet : SOverflow with type int_t = Z.t module Congruence : S with type int_t = Z.t diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index a60b7a6cb1..0a9a8dfd97 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -250,7 +250,426 @@ struct ] end +module BitFieldTest (I : IntDomain.SOverflow with type int_t = Z.t) = +struct +module I = IntDomain.SOverflowUnlifter (I) + + let ik = Cil.IInt + + let assert_equal x y = + OUnit.assert_equal ~printer:I.show x y + + + let test_of_int_to_int _ = + let b1 = I.of_int ik (of_int 17) in + OUnit.assert_equal 17 (I.to_int b1 |> Option.get |> to_int) + + let test_to_int_of_int _ = + OUnit.assert_equal None (I.to_int (I.bot_of ik)); + OUnit.assert_equal (of_int 13) (I.to_int (I.of_int ik (of_int 13)) |> Option.get); + OUnit.assert_equal None (I.to_int (I.top_of ik)); + OUnit.assert_equal None (I.to_int (I.join ik (I.of_int ik (of_int 13)) (I.of_int ik (of_int 14)))) + + let test_equal_to _ = + let b1 = I.join ik (I.of_int ik (of_int 4)) (I.of_int ik (of_int 2)) in + OUnit.assert_equal `Top (I.equal_to (Z.of_int 4) b1); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 2) b1); + + OUnit.assert_equal `Top (I.equal_to (Z.of_int 0) b1); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 6) b1); + + OUnit.assert_equal `Neq (I.equal_to (Z.of_int 1) b1); + OUnit.assert_equal `Neq (I.equal_to (Z.of_int 3) b1); + OUnit.assert_equal `Neq (I.equal_to (Z.of_int 5) b1); + + let b2 =I.of_int ik (of_int 123) in + OUnit.assert_equal `Eq (I.equal_to (Z.of_int 123) b2) + + let test_join _ = + let b1 = I.of_int ik (of_int 9) in + let b2 = I.of_int ik (of_int 2) in + let bjoin = I.join ik b1 b2 in + assert_bool "num1 leq join" (I.leq b1 bjoin); + assert_bool "num2 leq join" (I.leq b2 bjoin); + + + OUnit.assert_equal `Top (I.equal_to (Z.of_int 9) bjoin); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 2) bjoin); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 11) bjoin) + + let test_meet _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 3) in + let bf12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 7) in + let b4 = I.of_int ik (of_int 4) in + let bf34 = I.join ik b3 b4 in + + let bmeet2 = I.meet ik bf12 bf34 in + + OUnit.assert_equal `Top (I.equal_to (Z.of_int 5) bmeet2); + OUnit.assert_equal `Top (I.equal_to (Z.of_int 7) bmeet2) + + let test_leq_1 _ = + let b1 = I.of_int ik (of_int 13) in + let b2 = I.of_int ik (of_int 5) in + + let bjoin = I.join ik b1 b2 in + + OUnit.assert_bool "13 leq 13" (I.leq b1 b1); + OUnit.assert_bool "5 leq 5" (I.leq b2 b2); + + OUnit.assert_bool "5 leq 13" (I.leq b2 bjoin); + OUnit.assert_bool "not 13 leq 5" (not (I.leq bjoin b2)) + + let test_leq_2 _ = + let b1 = I.of_int ik (of_int 7) in + + OUnit.assert_bool "bot leq 7" (I.leq (I.bot_of ik) b1); + OUnit.assert_bool "7 leq top" (I.leq b1 (I.top_of ik)) + + let test_wrap_1 _ = + let z = of_int 31376 in + let b_uint8 = I.of_int IChar z in + let b_sint8 = I.of_int ISChar z in + let b_uint16 = I.of_int IUShort z in + let b_sint16 = I.of_int IShort z in + + (* See https://www.simonv.fr/TypesConvert/?integers *) + assert_equal (I.of_int IChar (of_int 144)) b_uint8; + assert_equal (I.of_int ISChar (of_int (-112))) b_sint8; + assert_equal (I.of_int IUShort (of_int 31376)) b_uint16; + assert_equal (I.of_int IShort (of_int 31376)) b_sint16 + + let test_wrap_2 _ = + let z1 = of_int 30867 in + let z2 = of_int 30870 in + let join_cast_unsigned = I.join IChar (I.of_int IChar z1) (I.of_int IChar z2) in + + let expected_unsigned = I.join IChar (I.of_int IChar (of_int 147)) (I.of_int IChar (of_int 150)) in + + let expected_signed = I.join IChar (I.of_int IChar (of_int (-106))) (I.of_int IChar (of_int (-109))) in + + assert_equal expected_unsigned join_cast_unsigned; + assert_equal expected_signed join_cast_unsigned + + let test_widen_1 _ = + let b1 = I.of_int ik (of_int 3) in + let b2 = I.of_int ik (of_int 17) in + + (* widen both masks *) + assert_equal (I.top_of ik) (I.widen ik b1 b2); + + (* no widening *) + let bjoin = I.join ik b1 b2 in + assert_equal bjoin (I.widen ik bjoin b1) + + + let test_widen_2 _ = + let b1 = I.of_int ik (of_int 123613) in + let b2 = I.of_int ik (of_int 613261) in + + (* no widening needed *) + assert_bool "join leq widen" (I.leq (I.join ik b1 b2) (I.widen ik b1 b2)) + + let test_of_interval _ = + let intvl= (of_int 3, of_int 17) in + let b1 = I.of_interval ik intvl in + + for i = 3 to 17 do + assert_bool (string_of_int i) (I.equal_to (of_int i) b1 = `Top) + done + + let test_of_bool _ = + let b1 = I.of_bool ik true in + let b2 = I.of_bool ik false in + + assert_bool "true" (I.equal_to (of_int 1) b1 = `Eq); + assert_bool "false" (I.equal_to (of_int 0) b2 = `Eq) + + let test_to_bool _ = + let b1 = I.of_int ik (of_int 3) in + let b2 = I.of_int ik (of_int (-6)) in + let b3 = I.of_int ik (of_int 0) in + + let b12 = I.join ik b1 b2 in + let b13 = I.join ik b1 b3 in + let b23 = I.join ik b2 b3 in + + assert_bool "3" (I.to_bool b1 = Some true); + assert_bool "-6" (I.to_bool b2 = Some true); + assert_bool "0" (I.to_bool b3 = Some false); + + assert_bool "3 | -6" (I.to_bool b12 = Some true); + assert_bool "3 | 0" (I.to_bool b13 = None); + assert_bool "-6 | 0" (I.to_bool b23 = None) + + let test_cast_to _ = + let b1 = I.of_int ik (of_int 1234) in + + assert_equal (I.of_int IChar (of_int (210))) (I.cast_to IChar b1); + assert_equal (I.of_int ISChar (of_int (-46))) (I.cast_to ISChar b1); + + assert_equal (I.of_int IUInt128 (of_int 1234)) (I.cast_to IUInt128 b1) + + (* Bitwise *) + + let test_logxor _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_equal (I.of_int ik (of_int 20)) (I.logxor ik b1 b2); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 13) in + assert_bool "8 ?= 13 xor (5 | 17)" (I.equal_to (of_int 8) (I.logxor ik b12 b3) = `Top); + assert_bool "28 ?= 13 xor (5 | 17)" (I.equal_to (of_int 28) (I.logxor ik b12 b3) = `Top) + + let test_logand _ = + let b1 = I.of_int ik (of_int 7) in + let b2 = I.of_int ik (of_int 13) in + + assert_equal (I.of_int ik (of_int 5)) (I.logand ik b1 b2); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 12) in + assert_bool "4 ?= 12 and (7 | 12)" (I.equal_to (of_int 4) (I.logand ik b12 b3) = `Top); + assert_bool "12 ?= 12 and (7 | 12)" (I.equal_to (of_int 12) (I.logand ik b12 b3) = `Top) + + + let test_logor _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_equal (I.of_int ik (of_int 21)) (I.logor ik b1 b2); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 13) in + assert_bool "13 ?= 13 or (5 | 17)" (I.equal_to (of_int 13) (I.logor ik b12 b3) = `Top); + assert_bool "29 ?= 13 or (5 | 17)" (I.equal_to (of_int 29) (I.logor ik b12 b3) = `Top) + + let test_lognot _ = + let b1 = I.of_int ik (of_int 4) in + let b2 = I.of_int ik (of_int 12) in + + (* assumes two's complement *) + assert_equal (I.of_int ik (of_int (-5))) (I.lognot ik b1); + + let b12= I.join ik b1 b2 in + assert_bool "-13 ?= not (4 | 12)" (I.equal_to (of_int (-13)) (I.lognot ik b12) = `Top); + assert_bool "-5 ?= not (4 | 12)" (I.equal_to (of_int (-5)) (I.lognot ik b12) = `Top) + + let test_shift_left _ = + let stat1 = I.of_int ik (of_int 2) in + let stat2 = I.of_int ik (of_int 1) in + + assert_bool "2 << 1 = 4" (I.equal_to (of_int (4)) (I.shift_left ik stat1 stat2) = `Top) + + + let test_shift_right _ = + let stat1 = I.of_int ik (of_int 4) in + let stat2 = I.of_int ik (of_int 1) in + + assert_bool "4 >> 1 = 2" (I.equal_to (of_int (2)) (I.shift_left ik stat1 stat2) = `Top) + + + (* Arith *) + + + (* Comparisons *) + + let test_eq _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_bool "5 == 5" (I.eq ik b1 b1 = I.of_bool ik true); + assert_bool "5 == 17" (I.eq ik b1 b2 = I.of_bool ik false); + + let b12 = I.join ik b1 b2 in + assert_bool "5 == (5 | 17)" (I.eq ik b1 b12 = (I.join ik (I.of_bool ik true) (I.of_bool ik false))) + + let test_ne _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 17) in + + assert_bool "5 != 5" (I.ne ik b1 b1 = I.of_bool ik false); + assert_bool "5 != 17" (I.ne ik b1 b2 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + assert_bool "5 != (5 | 17)" (I.ne ik b1 b12 = (I.join ik (I.of_bool ik false) (I.of_bool ik true))) + + let test_le _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 14) in + + assert_bool "5 <= 5" (I.le ik b1 b1 = I.of_bool ik true); + assert_bool "5 <= 14" (I.le ik b1 b2 = I.of_bool ik true); + assert_bool "14 <= 5" (I.le ik b2 b1 = I.of_bool ik false); + + let b12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 17) in + assert_bool "17 <= (5 | 14)" (I.le ik b3 b12 = I.of_bool ik false); + + let b4 = I.of_int ik (of_int 13) in + assert_bool "13 <= (5 | 14)" (I.le ik b4 b12 = (I.join ik (I.of_bool ik false) (I.of_bool ik true))); + + let b5 = I.of_int ik (of_int 5) in + assert_bool "5 <= (5 | 14)" (I.le ik b5 b12 = I.join ik (I.of_bool ik true) (I.of_bool ik false)); + + let b6 = I.of_int ik (of_int 4) in + assert_bool "4 <= (5 | 14)" (I.le ik b6 b12 = I.of_bool ik true) + + + let test_ge _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 14) in + + assert_bool "5 >= 5" (I.ge ik b1 b1 = I.of_bool ik true); + assert_bool "5 >= 14" (I.ge ik b1 b2 = I.of_bool ik false); + assert_bool "14 >= 5" (I.ge ik b2 b1 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 2) in + assert_bool "2 >= (5 | 14)" (I.ge ik b3 b12 = I.of_bool ik false); + + let b4 = I.of_int ik (of_int 13) in + assert_bool "13 >= (5 | 14)" (I.ge ik b4 b12 = (I.join ik (I.of_bool ik true) (I.of_bool ik false))); + + let b6 = I.of_int ik (of_int 15) in + assert_bool "15 >= (5 | 14)" (I.ge ik b6 b12 = I.of_bool ik true) + + let test_lt _ = + let b1 = I.of_int ik (of_int 7) in + let b2 = I.of_int ik (of_int 13) in + + assert_bool "7 < 7" (I.lt ik b1 b1 = I.of_bool ik false); + assert_bool "7 < 13" (I.lt ik b1 b2 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + let b3 = I.of_int ik (of_int 4) in + assert_bool "4 < (7 | 13)" (I.lt ik b3 b12 = I.of_bool ik true); + + let b4 = I.of_int ik (of_int 8) in + assert_bool "8 < (7 | 13)" (I.lt ik b4 b12 = I.join ik (I.of_bool ik false) (I.of_bool ik true)) + + let test_gt _ = + let b1 = I.of_int ik (of_int 5) in + let b2 = I.of_int ik (of_int 14) in + + + assert_bool "5 > 5" (I.gt ik b1 b1 = I.of_bool ik false); + assert_bool "5 > 14" (I.gt ik b1 b2 = I.of_bool ik false); + assert_bool "14 > 5" (I.gt ik b2 b1 = I.of_bool ik true); + + let b12 = I.join ik b1 b2 in + + let b3 = I.of_int ik (of_int 2) in + assert_bool "2 > (5 | 14)" (I.gt ik b3 b12 = I.of_bool ik false); + + let b4 = I.of_int ik (of_int 13) in + assert_bool "13 > (5 | 14)" (I.gt ik b4 b12 = (I.join ik (I.of_bool ik false) (I.of_bool ik true))); + + let b5 = I.of_int ik (of_int 5) in + assert_bool "5 > (5 | 14)" (I.gt ik b5 b12 = I.join ik (I.of_bool ik false) (I.of_bool ik true)); + + let b6 = I.of_int ik (of_int 4) in + assert_bool "4 > (5 | 14)" (I.gt ik b6 b12 = (I.of_bool ik false) ) + + let test_starting _ = + let bf1 = I.starting ik (of_int 17) in + + assert_bool "17" (I.equal_to (of_int 17) bf1 = `Top); + assert_bool "18" (I.equal_to (of_int 18) bf1 = `Top); + + assert_bool "-3" (I.equal_to (of_int (-3)) bf1 = `Neq); + + let bf2 = I.starting ik (of_int (-17)) in + + assert_bool "-16" (I.equal_to (of_int (-16)) bf2 = `Top); + assert_bool "-17" (I.equal_to (of_int (-17)) bf2 = `Top) + + + let test_ending _ = + let bf = I.ending ik (of_int 17) in + + assert_bool "-4" (I.equal_to (of_int (-4)) bf = `Top); + assert_bool "16" (I.equal_to (of_int 16) bf = `Top); + + let bf2 = I.ending ik (of_int (-17)) in + + assert_bool "-16" (I.equal_to (of_int (-16)) bf2 = `Top); + assert_bool "-18" (I.equal_to (of_int (-18)) bf2 = `Top); + + assert_bool "17" (I.equal_to (of_int 17) bf2 = `Neq) + + let test_refine_with_congruence _ = + let bf = I.top_of ik in + + let bf_refined1= I.refine_with_congruence ik bf (Some (Z.of_int 3, Z.of_int 4)) in + assert_bool "3" (I.equal_to (of_int 3) bf_refined1 = `Top); + let bf_refined2= I.refine_with_congruence ik bf_refined1 (Some (Z.of_int 1, Z.of_int 1)) in + assert_bool "1" (I.equal_to (of_int 1) bf_refined2 = `Eq); + let bf_refined3= I.refine_with_congruence ik bf_refined2 (Some (Z.of_int 5, Z.of_int 0)) in + assert_bool "5" (I.equal_to (of_int 5) bf_refined3 = `Eq) + + let test_refine_with_inclusion_list _ = + let bf = I.top_of ik in + + let list = List.map of_int [-2;3;23; 26] in + let bf_refined = I.refine_with_incl_list ik bf (Some list) in + + List.iter (fun i -> assert_bool (Z.to_string i) (I.equal_to i bf_refined = `Top)) list + + let test () =[ + "test_of_int_to_int" >:: test_of_int_to_int; + "test_to_int_of_int" >:: test_to_int_of_int; + "test_equal_to" >:: test_equal_to; + + "test_join" >:: test_join; + "test_meet" >:: test_meet; + + "test_leq_1" >:: test_leq_1; + "test_leq_2" >:: test_leq_2; + + "test_wrap_1" >:: test_wrap_1; + "test_wrap_2" >:: test_wrap_2; + + "test_widen_1" >:: test_widen_1; + "test_widen_2" >:: test_widen_2; + + "test_of_interval" >:: test_of_interval; + "test_of_bool" >:: test_of_bool; + "test_to_bool" >:: test_to_bool; + "test_cast_to" >:: test_cast_to; + + "test_logxor" >:: test_logxor; + "test_logand" >:: test_logand; + "test_logor" >:: test_logor; + "test_lognot" >:: test_lognot; + "test_shift_left" >:: test_shift_left; + "test_shift_right" >:: test_shift_right; + + "test_eq" >:: test_eq; + "test_ne" >:: test_ne; + "test_le" >:: test_le; + "test_ge" >:: test_ge; + "test_lt" >:: test_lt; + "test_gt" >:: test_gt; + + "test_starting" >:: test_starting; + "test_ending" >:: test_ending; + + "test_refine_with_congruence" >:: test_refine_with_congruence; + "test_refine_with_inclusion_list" >:: test_refine_with_inclusion_list; + ] + +end + module Interval = IntervalTest (IntDomain.Interval) +module BitField = BitFieldTest (IntDomain.BitField) module IntervalSet = IntervalTest (IntDomain.IntervalSet) module Congruence = @@ -330,6 +749,7 @@ let test () = "test_meet" >:: test_meet; "test_excl_list">:: test_ex_set; "interval" >::: Interval.test (); + "bitField" >::: BitField.test (); "intervalSet" >::: IntervalSet.test (); "congruence" >::: Congruence.test (); "intDomTuple" >::: IntDomTuple.test (); From 5ce8db7742c88c12e8ca5de8c0edf015d890ba49 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 19 Nov 2024 13:58:41 +0100 Subject: [PATCH 037/111] add simple tests --- src/cdomain/value/cdomains/intDomain.ml | 72 ++++++++++++++----------- tests/unit/cdomains/intDomainTest.ml | 22 ++++++-- 2 files changed, 59 insertions(+), 35 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 6a5226a3bd..dfe5b8da8c 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1226,8 +1226,6 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) - let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - let make_bitone_msk pos = Ints_t.shift_left Ints_t.one pos let make_bitzero_msk pos = Ints_t.lognot @@ make_bitone_msk pos let make_lsb_bitmask pos = Ints_t.sub (make_bitone_msk pos) Ints_t.one @@ -1289,35 +1287,47 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct if is_const n_bf then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) - let min ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in - let impossibleBitMask = bits_undef (z,o) in - let guaranteedBits = bits_set (z,o) in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - if isSigned ik then - let signBitMask = make_bitone_msk (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint guaranteedBits) - - let max ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in - let impossibleBitMask = bits_undef (z,o) in - let guaranteedBits = bits_set (z,o) in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in (* Necessary? *) - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - + let min ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + let max ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + + if isSigned ik then + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero + end module BitFieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 0a9a8dfd97..5e49252aae 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -463,15 +463,29 @@ module I = IntDomain.SOverflowUnlifter (I) let test_shift_left _ = let stat1 = I.of_int ik (of_int 2) in let stat2 = I.of_int ik (of_int 1) in - - assert_bool "2 << 1 = 4" (I.equal_to (of_int (4)) (I.shift_left ik stat1 stat2) = `Top) + let eval = (I.shift_left ik stat1 stat2) in + let eq = (of_int(4)) in + assert_bool ("2 << 1 should be: \"4\" but was: \"" ^ I.show eval ^ "\"") (I.equal_to eq eval = `Eq); + + let stat1 = I.of_int ik (of_int (-2)) in + let stat2 = I.of_int ik (of_int 1) in + let eval = (I.shift_left ik stat1 stat2) in + let eq = (of_int(-4)) in + assert_bool ("2 << 1 should be: \"4\" but was: \"" ^ I.show eval ^ "\"") (I.equal_to eq eval = `Eq) let test_shift_right _ = - let stat1 = I.of_int ik (of_int 4) in + let stat1 = I.of_int ik (of_int (4)) in let stat2 = I.of_int ik (of_int 1) in + let eval = (I.shift_right ik stat1 stat2) in + let eq = (of_int (2)) in + assert_bool ("4 >> 1 should be: \"2\" but was: \"" ^ I.show eval ^ "\"" ^ I.show stat1) (I.equal_to eq eval = `Eq); - assert_bool "4 >> 1 = 2" (I.equal_to (of_int (2)) (I.shift_left ik stat1 stat2) = `Top) + let stat1 = I.of_int ik (of_int (-4)) in + let stat2 = I.of_int ik (of_int 1) in + let eval = (I.shift_right ik stat1 stat2) in + let eq = (of_int (-2)) in + assert_bool ("4 >> 1 should be: \"2\" but was: \"" ^ I.show eval ^ "\"" ^ I.show stat1) (I.equal_to eq eval = `Eq) (* Arith *) From 4170f7fc526b8f787d5ad3ba26de5c7111a9d7b9 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 19 Nov 2024 14:39:53 +0100 Subject: [PATCH 038/111] fix small bug in constant shifting expecting isSigned ik to check if the value is signed --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index dfe5b8da8c..823007475f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1271,7 +1271,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let shift_right ik bf n_bf = let shift_right (z,o) c = let sign_msk = Ints_t.shift_left one_mask (Size.bit ik - c) in - if isSigned ik then + if (isSigned ik) && ((Ints_t.to_int o) < 0) then (Ints_t.shift_right z c, Ints_t.logor (Ints_t.shift_right o c) sign_msk) else (Ints_t.logor (Ints_t.shift_right z c) sign_msk, Ints_t.shift_right o c) From 811590db62ef875ea1caab59451d7a13d1229885 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 19 Nov 2024 16:12:36 +0100 Subject: [PATCH 039/111] added bitfield to quickcheck --- src/cdomain/value/cdomains/intDomain.ml | 98 ++++++++++++++---------- src/cdomain/value/cdomains/intDomain.mli | 2 + tests/unit/cdomains/intDomainTest.ml | 32 +++++--- tests/unit/maindomaintest.ml | 5 +- 4 files changed, 84 insertions(+), 53 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index e78db58ea1..56b37d4a3f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1265,11 +1265,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int module BArith = BitFieldArith (Ints_t) - let top () = (BArith.one_mask, BArith.one_mask) - let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = top () - let bot_of ik = bot () - let range ik bf = (BArith.min ik bf, BArith.max ik bf) let get_bit n i = (Ints_t.logand (Ints_t.shift_right n (i-1)) Ints_t.one) @@ -1287,21 +1282,26 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in (newz,newo) else - let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in + let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in (newz,newo)) in if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) else (new_bitfield, {underflow=underflow; overflow=overflow}) + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = (norm ik (top ())) |> fst + let bot_of ik = bot () + let show t = if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in if BArith.is_constant t then - Format.sprintf "[%08X, %08X] (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) + Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) else - Format.sprintf "[%08X, %08X]" (Ints_t.to_int z) (Ints_t.to_int o) + Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) @@ -1312,7 +1312,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let leq (x:t) (y:t) = (BArith.join x y) = y let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = y + let narrow ik x y = norm ik y |> fst let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) @@ -1366,13 +1366,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (* Bitwise *) - let logxor ik i1 i2 = BArith.logxor i1 i2 + let logxor ik i1 i2 = BArith.logxor i1 i2 |> norm ik |> fst - let logand ik i1 i2 = BArith.logand i1 i2 + let logand ik i1 i2 = BArith.logand i1 i2 |> norm ik |> fst - let logor ik i1 i2 = BArith.logor i1 i2 + let logor ik i1 i2 = BArith.logor i1 i2 |> norm ik |> fst - let lognot ik i1 = BArith.lognot i1 + let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst let shift_right ik a b = (top_of ik,{underflow=false; overflow=false}) @@ -1401,7 +1401,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rm = mu in let o3 = Ints_t.logor rv rm in let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) + norm ik (z3, o3) let sub ?no_ov ik (z1, o1) (z2, o2) = let pv = Ints_t.logand o1 (Ints_t.lognot z1) in @@ -1417,7 +1417,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rm = mu in let o3 = Ints_t.logor rv rm in let z3 = Ints_t.logor (Ints_t.lognot rv) rm in - ((z3, o3),{underflow=false; overflow=false}) + norm ik (z3, o3) let neg ?no_ov ik x = M.trace "bitfield" "neg"; @@ -1430,8 +1430,15 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let o2 = ref o2 in let z3 = ref BArith.one_mask in let o3 = ref BArith.zero_mask in - for i = Size.bit ik downto 0 do - if Ints_t.logand !o1 Ints_t.one == Ints_t.one then + let size = if isSigned ik then Size.bit ik - 1 else Size.bit ik in + let bitmask = Ints_t.of_int(Z.to_int(Z.lognot (fst (Size.range ik)))) in + let signBitUndef1 = Ints_t.logand (Ints_t.logand !z1 !o1) bitmask in + let signBitUndef2 = Ints_t.logand (Ints_t.logand !z2 !o2) bitmask in + let signBitUndef = Ints_t.logor signBitUndef1 signBitUndef2 in + let signBitDefO = Ints_t.logand (Ints_t.logxor !o1 !o2) bitmask in + let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor !o1 !o2)) bitmask in + for i = size downto 0 do + (if Ints_t.logand !o1 Ints_t.one == Ints_t.one then if Ints_t.logand !z1 Ints_t.one == Ints_t.one then let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in z3 := Ints_t.logor !z3 tmp; @@ -1439,18 +1446,20 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in z3 := fst tmp; - o3 := snd tmp - ; + o3 := snd tmp;); + z1 := Ints_t.shift_right !z1 1; o1 := Ints_t.shift_right !o1 1; z2 := Ints_t.shift_left !z2 1; o2 := Ints_t.shift_left !o2 1; - done; - ((!z3, !o3),{underflow=false; overflow=false}) + done; + if isSigned ik then z3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefZ !z3); + if isSigned ik then o3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefO !o3); + norm ik (!z3, !o3) let rec div ?no_ov ik (z1, o1) (z2, o2) = - if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let res = Ints_t.div z1 z2 in ((res, Ints_t.lognot res),{underflow=false; overflow=false})) - else (top_of ik,{underflow=false; overflow=false}) + let res = if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let tmp = Ints_t.div z1 z2 in (tmp, Ints_t.lognot tmp)) else top_of ik in + norm ik res let rem ik x y = M.trace "bitfield" "rem"; @@ -1520,30 +1529,39 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let congruenceMask = Ints_t.lognot m in let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - (newz, newo) + norm ik (newz, newo) |> fst else top_of ik | _ -> top_of ik - let refine_with_interval ik t i = t + let refine_with_interval ik t i = norm ik t |> fst - let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = t + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst let invariant_ikind e ik = M.trace "bitfield" "invariant_ikind"; failwith "Not implemented" - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - M.trace "bitfield" "refine_with_congruence"; - top_of ik - - let refine_with_interval ik a b = + let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in + match bf, cong with + | (z,o), Some (c, m) -> + if is_power_of_two m then + let congruenceMask = Ints_t.lognot m in + let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in + let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + norm ik (newz, newo) |> fst + else + top_of ik + | _ -> top_of ik + + let refine_with_interval ik bf (int: (int_t * int_t) option) : t = M.trace "bitfield" "refine_with_interval"; - top_of ik + norm ik bf |> fst - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + let refine_with_excl_list ik bf (excl : (int_t list * (int64 * int64)) option) : t = M.trace "bitfield" "refine_with_excl_list"; - top_of ik + norm ik bf |> fst let refine_with_incl_list ik t (incl : (int_t list) option) : t = (* loop over all included ints *) @@ -1552,17 +1570,17 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | Some ls -> List.fold_left (fun acc x -> BArith.join acc (BArith.of_int x)) (bot()) ls in - BArith.meet t incl_list_masks + meet ik t incl_list_masks let arbitrary ik = let open QCheck.Iter in - let int_arb1 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let int_arb2 = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb1 int_arb2 in + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + (*let pair_arb = QCheck.pair int_arb int_arb in*) let shrink = function - | (z, o) -> (GobQCheck.shrink int_arb1 z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb2 o >|= fun o -> (z, o)) + | (z, o) -> (GobQCheck.shrink int_arb z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb o >|= fun o -> (z, o)) in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun x -> norm ik x |> fst ) pair_arb) + QCheck.(set_shrink shrink @@ set_print show @@ map (fun i -> of_int ik i |> fst ) int_arb) + (* QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (join ik (fst (of_int ik i1)) (fst (of_int ik i2))) |> fst ) pair_arb)*) let project ik p t = t end diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index e7667c9b14..d28c91021c 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -408,6 +408,8 @@ module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) op module Interval : SOverflow with type int_t = Z.t +module Bitfield : SOverflow with type int_t = Z.t + module IntervalSet : SOverflow with type int_t = Z.t module Congruence : S with type int_t = Z.t diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index b1cab10b80..cd030c2eb8 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -324,21 +324,30 @@ end module BitfieldTest (B : IntDomain.SOverflow with type int_t = Z.t) = struct module B = IntDomain.SOverflowUnlifter (B) - let ik = Cil.IInt - let i65536 = B.of_Bitfield - let i65537 = I.of_interval ik (Z.zero, of_int 65537) - let imax = I.of_interval ik (Z.zero, of_int 2147483647) - let imin = I.of_interval ik (of_int (-2147483648), Z.zero) -end + let ik = Cil.IUChar -module Bitfield = BitfieldTest(IntDomain.Bitfield) + let of_list ik is = List.fold_left (fun acc x -> B.join ik acc (B.of_int ik x)) (B.bot ()) is + let v1 = Z.of_int 0 + let v2 = Z.of_int 13 + let vr = Z.mul v1 v2 -module test = -struct - module B = IntDomain.Bitfield - B. + let is = [0;1;2;3;4;5;6;7] + let res = [0;13;26;39;52;65;78;91] + + let b1 = of_list ik (List.map Z.of_int is) + let b2 = B.of_int ik v2 + let br = of_list ik (List.map Z.of_int res) + + let test_add _ = assert_equal ~cmp:B.leq ~printer:B.show br (B.mul ik b2 b1) + + let test () = [ + "test_add" >:: test_add; + ] end + +module Bitfield = BitfieldTest(IntDomain.Bitfield) + let test () = "intDomainTest" >::: [ "int_Integers" >::: A.test (); @@ -352,4 +361,5 @@ let test () = "intervalSet" >::: IntervalSet.test (); "congruence" >::: Congruence.test (); "intDomTuple" >::: IntDomTuple.test (); + "bitfield" >::: Bitfield.test (); ] diff --git a/tests/unit/maindomaintest.ml b/tests/unit/maindomaintest.ml index 4b379a252f..e89bbfc111 100644 --- a/tests/unit/maindomaintest.ml +++ b/tests/unit/maindomaintest.ml @@ -42,10 +42,11 @@ let domains: (module Lattice.S) list = [ let nonAssocDomains: (module Lattice.S) list = [] let intDomains: (module IntDomainProperties.S) list = [ - (module IntDomain.SOverflowUnlifter(IntDomain.Interval)); + (*(module IntDomain.SOverflowUnlifter(IntDomain.Interval)); (module IntDomain.Enums); (module IntDomain.Congruence); - (module IntDomain.SOverflowUnlifter(IntDomain.IntervalSet)); + (module IntDomain.SOverflowUnlifter(IntDomain.IntervalSet));*) + (module IntDomain.SOverflowUnlifter(IntDomain.Bitfield)); (* (module IntDomain.Flattened); *) (* (module IntDomain.Interval32); *) (* (module IntDomain.Booleans); *) From 6999a2007087964f2418aad2c24b40af7cb1f168 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 19 Nov 2024 16:13:58 +0100 Subject: [PATCH 040/111] two bug fixes --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 393e9fb882..eaa3e838e2 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1282,7 +1282,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (get_bit o (Size.bit ik))) in (newz,newo) else - let newz = Ints_t.logor z (Ints_t.neg (Ints_t.of_bigint max_ik)) in + let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in (newz,newo)) in @@ -1292,7 +1292,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let top () = (BArith.one_mask, BArith.one_mask) let bot () = (BArith.zero_mask, BArith.zero_mask) let top_of ik = (norm ik (top ())) |> fst - let bot_of ik = (norm ik (bot ())) |> fst + let bot_of ik = bot () let show t = if t = bot () then "bot" else From 146d858a1a7c35ae4abde4b03668384c919863b7 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 19 Nov 2024 16:19:17 +0100 Subject: [PATCH 041/111] hotfix compilationn --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4580dff834..c0e10e80d4 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1521,7 +1521,7 @@ module BitFieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik (!z3, !o3) let rec div ?no_ov ik (z1, o1) (z2, o2) = - let res = if BArith.is_constant (z1, o1) && BArith.is_constant (z2, o2) then (let tmp = Ints_t.div z1 z2 in (tmp, Ints_t.lognot tmp)) else top_of ik in + let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = Ints_t.div z1 z2 in (tmp, Ints_t.lognot tmp)) else top_of ik in norm ik res let rem ik x y = From 6a32e4220c49e6cdfb613eacf55d9ba377bd14b7 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 19 Nov 2024 16:25:10 +0100 Subject: [PATCH 042/111] hotfix compilation again --- src/cdomain/value/cdomains/intDomain.ml | 2 +- src/cdomain/value/cdomains/intDomain.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a98b7e2eba..eaaf4b7c30 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1368,7 +1368,7 @@ module BitFieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in - if BArith.is_constant t then + if BArith.is_const t then Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) else Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index edabc8c754..3c7fb21c23 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -410,7 +410,7 @@ module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) op module Interval : SOverflow with type int_t = Z.t -module Bitfield : SOverflow with type int_t = Z.t +module BitField : SOverflow with type int_t = Z.t module IntervalSet : SOverflow with type int_t = Z.t From 47b7a56deb969d01f5b0c41c72d334e2df2c31af Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 19 Nov 2024 16:39:24 +0100 Subject: [PATCH 043/111] hotfix name clash after merge --- src/cdomain/value/cdomains/intDomain.ml | 6 +++--- src/cdomain/value/cdomains/intDomain.mli | 4 ++-- tests/unit/cdomains/intDomainTest.ml | 12 ++++++------ 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index eaaf4b7c30..9eddc9767e 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1330,7 +1330,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct end -module BitFieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct let name () = "bitfield" type int_t = Ints_t.t type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] @@ -2219,7 +2219,7 @@ end module IntIkind = struct let ikind () = Cil.IInt end module Interval = IntervalFunctor (IntOps.BigIntOps) -module BitField = BitFieldFunctor (IntOps.BigIntOps) +module Bitfield = BitfieldFunctor (IntOps.BigIntOps) module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) @@ -3893,7 +3893,7 @@ module IntDomTupleImpl = struct module I3 = SOverflowLifter (Enums) module I4 = SOverflowLifter (Congruence) module I5 = IntervalSetFunctor (IntOps.BigIntOps) - module I6 = BitFieldFunctor (IntOps.BigIntOps) + module I6 = BitfieldFunctor (IntOps.BigIntOps) type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option [@@deriving eq, ord, hash] diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 3c7fb21c23..d6bb233aee 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -402,7 +402,7 @@ module Lifted : IkindUnawareS with type t = [`Top | `Lifted of int64 | `Bot] and module IntervalFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option -module BitFieldFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) +module BitfieldFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) module IntervalSetFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list @@ -410,7 +410,7 @@ module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) op module Interval : SOverflow with type int_t = Z.t -module BitField : SOverflow with type int_t = Z.t +module Bitfield : SOverflow with type int_t = Z.t module IntervalSet : SOverflow with type int_t = Z.t diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 2b1d9e272f..ce72deded0 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -250,7 +250,7 @@ struct ] end -module BitFieldTest (I : IntDomain.SOverflow with type int_t = Z.t) = +module BitfieldTest (I : IntDomain.SOverflow with type int_t = Z.t) = struct module I = IntDomain.SOverflowUnlifter (I) @@ -683,7 +683,7 @@ module I = IntDomain.SOverflowUnlifter (I) end module Interval = IntervalTest (IntDomain.Interval) -module BitField = BitFieldTest (IntDomain.BitField) +module Bitfield = BitfieldTest (IntDomain.Bitfield) module IntervalSet = IntervalTest (IntDomain.IntervalSet) module Congruence = @@ -754,7 +754,7 @@ struct end -module BitfieldTest (B : IntDomain.SOverflow with type int_t = Z.t) = +module TEMPDEBUG_TODO_REMOVE_TEST (B : IntDomain.SOverflow with type int_t = Z.t) = struct module B = IntDomain.SOverflowUnlifter (B) let ik = Cil.IUChar @@ -779,7 +779,7 @@ struct ] end -module Bitfield = BitfieldTest(IntDomain.Bitfield) +module TEMPDEBUG_TODO_REMOVE = TEMPDEBUG_TODO_REMOVE_TEST(IntDomain.Bitfield) let test () = "intDomainTest" >::: [ @@ -791,9 +791,9 @@ let test () = "test_meet" >:: test_meet; "test_excl_list">:: test_ex_set; "interval" >::: Interval.test (); - "bitField" >::: BitField.test (); + "bitfield" >::: Bitfield.test (); "intervalSet" >::: IntervalSet.test (); "congruence" >::: Congruence.test (); "intDomTuple" >::: IntDomTuple.test (); - "bitfield" >::: Bitfield.test (); + "TEMPDEBUG_TODO_REMOVE" >::: TEMPDEBUG_TODO_REMOVE.test (); ] From 5606e678cc4dc3390639e69a7a31a02230d4f77e Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 19 Nov 2024 17:20:26 +0100 Subject: [PATCH 044/111] logand fix --- src/cdomain/value/cdomains/intDomain.ml | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 9eddc9767e..7648e83083 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1340,6 +1340,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let range ik bf = (BArith.min ik bf, BArith.max ik bf) let norm ?(suppress_ovwarn=false) ik (z,o) = + if BArith.is_undef (z,o) then + ((z,o), {underflow=false; overflow=false}) + else let (min_ik, max_ik) = Size.range ik in let (min,max) = range ik (z,o) in @@ -1399,9 +1402,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_interval ?(suppress_ovwarn=false) ik (x,y) = (* naive implentation -> horrible O(n) runtime *) let (min_ik, max_ik) = Size.range ik in - let current = ref (min_ik) in + let current = ref (Z.of_int (Ints_t.to_int x)) in let bf = ref (bot ()) in - while Z.leq !current max_ik do + while Z.leq !current (Z.of_int (Ints_t.to_int y)) do bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); current := Z.add !current Z.one done; @@ -1423,14 +1426,16 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | None -> top_of ik | Some x -> of_bool ik (f x) - let log2 f ik i1 i2 = match (to_bool i1, to_bool i2) with - | None, None -> top_of ik - | None, Some x | Some x, None -> of_bool ik x + let log2 f ~annihilator ik i1 i2 = match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator | Some x, Some y -> of_bool ik (f x y) - let c_logor ik i1 i2 = log2 (||) ik i1 i2 + | _ -> top_of ik - let c_logand ik i1 i2 = log2 (&&) ik i1 i2 + let c_logor = log2 (||) ~annihilator:true + let c_logand = log2 (&&) ~annihilator:false + let c_lognot ik i1 = log1 not ik i1 From 8b1fbfc9ced84077ffe718114165558217c16d21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 19 Nov 2024 17:25:07 +0100 Subject: [PATCH 045/111] bug fixes for arith ops --- src/cdomain/value/cdomains/intDomain.ml | 63 +++++++++++++------------ 1 file changed, 32 insertions(+), 31 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 7648e83083..c85e20e5f8 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1465,11 +1465,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int of Vishwanathan et al. *) - let add ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in + let add_paper pv pm qv qm = let sv = Ints_t.add pv qv in let sm = Ints_t.add pm qm in let sigma = Ints_t.add sv sm in @@ -1477,6 +1473,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let mu = Ints_t.logor (Ints_t.logor pm qm) chi in let rv = Ints_t.logand sv (Ints_t.lognot mu) in let rm = mu in + (rv, rm) + + let add ?no_ov ik (z1, o1) (z2, o2) = + let pv = Ints_t.logand o1 (Ints_t.lognot z1) in + let pm = Ints_t.logand o1 z1 in + let qv = Ints_t.logand o2 (Ints_t.lognot z2) in + let qm = Ints_t.logand o2 z2 in + let (rv, rm) = add_paper pv pm qv qm in let o3 = Ints_t.logor rv rm in let z3 = Ints_t.logor (Ints_t.lognot rv) rm in norm ik (z3, o3) @@ -1502,42 +1506,39 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int sub ?no_ov ik BArith.zero x let mul ?no_ov ik (z1, o1) (z2, o2) = - let z1 = ref z1 in - let o1 = ref o1 in - let z2 = ref z2 in - let o2 = ref o2 in - let z3 = ref BArith.one_mask in - let o3 = ref BArith.zero_mask in + let pm = ref (Ints_t.logand z1 o1) in + let pv = ref (Ints_t.logand o1 (Ints_t.lognot z1)) in + let qm = ref (Ints_t.logand z2 o2) in + let qv = ref (Ints_t.logand o2 (Ints_t.lognot z2)) in + let accv = ref BArith.zero_mask in + let accm = ref BArith.zero_mask in let size = if isSigned ik then Size.bit ik - 1 else Size.bit ik in let bitmask = Ints_t.of_int(Z.to_int(Z.lognot (fst (Size.range ik)))) in - let signBitUndef1 = Ints_t.logand (Ints_t.logand !z1 !o1) bitmask in - let signBitUndef2 = Ints_t.logand (Ints_t.logand !z2 !o2) bitmask in + let signBitUndef1 = Ints_t.logand (Ints_t.logand z1 o1) bitmask in + let signBitUndef2 = Ints_t.logand (Ints_t.logand z2 o2) bitmask in let signBitUndef = Ints_t.logor signBitUndef1 signBitUndef2 in - let signBitDefO = Ints_t.logand (Ints_t.logxor !o1 !o2) bitmask in - let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor !o1 !o2)) bitmask in + let signBitDefO = Ints_t.logand (Ints_t.logxor o1 o2) bitmask in + let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor o1 o2)) bitmask in for i = size downto 0 do - (if Ints_t.logand !o1 Ints_t.one == Ints_t.one then - if Ints_t.logand !z1 Ints_t.one == Ints_t.one then - let tmp = Ints_t.add (Ints_t.logand !z3 !o3) !o2 in - z3 := Ints_t.logor !z3 tmp; - o3 := Ints_t.logor !o3 tmp - else - let tmp = fst (add ik (!z3, !o3) (!z2, !o2)) in - z3 := fst tmp; - o3 := snd tmp;); - - z1 := Ints_t.shift_right !z1 1; - o1 := Ints_t.shift_right !o1 1; - z2 := Ints_t.shift_left !z2 1; - o2 := Ints_t.shift_left !o2 1; + (if Ints_t.logand !pm Ints_t.one == Ints_t.one then + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) + else if Ints_t.logand !pv Ints_t.one == Ints_t.one then + accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); + + pv := Ints_t.shift_right !pv 1; + pm := Ints_t.shift_right !pm 1; + qv := Ints_t.shift_left !qv 1; + qm := Ints_t.shift_left !qm 1; done; + let o3 = ref(Ints_t.logor !accv !accm) in + let z3 = ref(Ints_t.logor (Ints_t.lognot !accv) !accm) in if isSigned ik then z3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefZ !z3); if isSigned ik then o3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefO !o3); - norm ik (!z3, !o3) let rec div ?no_ov ik (z1, o1) (z2, o2) = - let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = Ints_t.div z1 z2 in (tmp, Ints_t.lognot tmp)) else top_of ik in + let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = Ints_t.div z1 z2 in (Ints_t.lognot tmp, tmp)) else top_of ik in norm ik res let rem ik x y = From 4bf31cc004d9064f2e7f98e8d7f378442afcbdfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 19 Nov 2024 17:31:12 +0100 Subject: [PATCH 046/111] fixed norm --- src/cdomain/value/cdomains/intDomain.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c85e20e5f8..f6e44eff5e 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1211,7 +1211,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bits_undef (z,o) = Ints_t.lognot (Ints_t.logxor z o) let is_const (z,o) = (Ints_t.logxor z o) = one_mask - let is_undef (z,o) = Ints_t.compare (bits_undef (z,o)) Ints_t.zero != 0 + let is_invalid (z,o) = Ints_t.compare (Ints_t.lognot (Ints_t.logand z o)) Ints_t.zero != 0 let nabla x y= if x = Ints_t.logor x y then x else one_mask @@ -1246,7 +1246,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct in aux n 0 in ilog2 (Size.bit ik) - let break_down_lsb ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_undef (z,o) then None + let break_down_lsb ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_invalid (z,o) then None else let rec break_down c_lst i = if i < 0 then c_lst else @@ -1340,7 +1340,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let range ik bf = (BArith.min ik bf, BArith.max ik bf) let norm ?(suppress_ovwarn=false) ik (z,o) = - if BArith.is_undef (z,o) then + if BArith.is_invalid (z,o) then ((z,o), {underflow=false; overflow=false}) else let (min_ik, max_ik) = Size.range ik in From 0b4b4a10a7b5446309ba36c0e9147fddc61adf69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 19 Nov 2024 19:25:40 +0100 Subject: [PATCH 047/111] is_invalid and mul fix --- src/cdomain/value/cdomains/intDomain.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index f6e44eff5e..a97c5f055b 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1211,7 +1211,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bits_undef (z,o) = Ints_t.lognot (Ints_t.logxor z o) let is_const (z,o) = (Ints_t.logxor z o) = one_mask - let is_invalid (z,o) = Ints_t.compare (Ints_t.lognot (Ints_t.logand z o)) Ints_t.zero != 0 + let is_invalid (z,o) = Ints_t.compare (Ints_t.lognot (Ints_t.logor z o)) Ints_t.zero != 0 let nabla x y= if x = Ints_t.logor x y then x else one_mask @@ -1513,13 +1513,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let accv = ref BArith.zero_mask in let accm = ref BArith.zero_mask in let size = if isSigned ik then Size.bit ik - 1 else Size.bit ik in - let bitmask = Ints_t.of_int(Z.to_int(Z.lognot (fst (Size.range ik)))) in + let bitmask = Ints_t.of_bigint (fst (Size.range ik)) in let signBitUndef1 = Ints_t.logand (Ints_t.logand z1 o1) bitmask in let signBitUndef2 = Ints_t.logand (Ints_t.logand z2 o2) bitmask in let signBitUndef = Ints_t.logor signBitUndef1 signBitUndef2 in let signBitDefO = Ints_t.logand (Ints_t.logxor o1 o2) bitmask in let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor o1 o2)) bitmask in - for i = size downto 0 do + for i = size downto 0 do (if Ints_t.logand !pm Ints_t.one == Ints_t.one then accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) else if Ints_t.logand !pv Ints_t.one == Ints_t.one then @@ -1530,9 +1530,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int pm := Ints_t.shift_right !pm 1; qv := Ints_t.shift_left !qv 1; qm := Ints_t.shift_left !qm 1; - done; - let o3 = ref(Ints_t.logor !accv !accm) in - let z3 = ref(Ints_t.logor (Ints_t.lognot !accv) !accm) in + done; + let (rv, rm) = add_paper !accv Ints_t.zero Ints_t.zero !accm in + let o3 = ref(Ints_t.logor rv rm) in + let z3 = ref(Ints_t.logor (Ints_t.lognot rv) rm) in if isSigned ik then z3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefZ !z3); if isSigned ik then o3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefO !o3); norm ik (!z3, !o3) From 15520a86696026603d50bc96193ac3d3a13e4e47 Mon Sep 17 00:00:00 2001 From: giaca Date: Tue, 19 Nov 2024 20:43:22 +0100 Subject: [PATCH 048/111] assertion function for shifts --- tests/unit/cdomains/intDomainTest.ml | 41 ++++++++++++---------------- 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index ce72deded0..992480a6be 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -460,33 +460,26 @@ module I = IntDomain.SOverflowUnlifter (I) assert_bool "-13 ?= not (4 | 12)" (I.equal_to (of_int (-13)) (I.lognot ik b12) = `Top); assert_bool "-5 ?= not (4 | 12)" (I.equal_to (of_int (-5)) (I.lognot ik b12) = `Top) - let test_shift_left _ = - let stat1 = I.of_int ik (of_int 2) in - let stat2 = I.of_int ik (of_int 1) in - let eval = (I.shift_left ik stat1 stat2) in - let eq = (of_int(4)) in - assert_bool ("2 << 1 should be: \"4\" but was: \"" ^ I.show eval ^ "\"") (I.equal_to eq eval = `Eq); - - let stat1 = I.of_int ik (of_int (-2)) in - let stat2 = I.of_int ik (of_int 1) in - let eval = (I.shift_left ik stat1 stat2) in - let eq = (of_int(-4)) in - assert_bool ("2 << 1 should be: \"4\" but was: \"" ^ I.show eval ^ "\"") (I.equal_to eq eval = `Eq) + (* TODO assumes join to be correct *) + let assert_shift shift symb ik a b res = + let lst2bf lst = List.map (fun x -> I.of_int ik @@ of_int x) lst |> List.fold_left (I.join ik) (I.bot ()) in + let stat1 = lst2bf a in + let stat2 = lst2bf b in + let eval = (shift ik stat1 stat2) in + let eq = lst2bf res in + let out_string = I.show stat1 ^ symb ^ I.show stat2 ^ " should be : \"" ^ I.show eq ^ "\" but was \"" ^ I.show eval ^ "\"" in + OUnit2.assert_equal ~cmp:(fun x y -> Option.value ~default:false @@ I.to_bool @@ I.eq ik x y) ~msg:out_string eq eval (* TODO msg *) + + let assert_shift_left ik a b res = assert_shift I.shift_left "<<" ik a b res + let assert_shift_right ik a b res = assert_shift I.shift_right ">>" ik a b res + let test_shift_left _ = + assert_shift_left ik [2] [1] [4]; + assert_shift_left ik [-2] [1] [-4] let test_shift_right _ = - let stat1 = I.of_int ik (of_int (4)) in - let stat2 = I.of_int ik (of_int 1) in - let eval = (I.shift_right ik stat1 stat2) in - let eq = (of_int (2)) in - assert_bool ("4 >> 1 should be: \"2\" but was: \"" ^ I.show eval ^ "\"" ^ I.show stat1) (I.equal_to eq eval = `Eq); - - let stat1 = I.of_int ik (of_int (-4)) in - let stat2 = I.of_int ik (of_int 1) in - let eval = (I.shift_right ik stat1 stat2) in - let eq = (of_int (-2)) in - assert_bool ("4 >> 1 should be: \"2\" but was: \"" ^ I.show eval ^ "\"" ^ I.show stat1) (I.equal_to eq eval = `Eq) - + assert_shift_right ik [4] [1] [2]; + assert_shift_right ik [-4] [1] [-2] (* Arith *) From d55eab5f9035dc07d9dcf9d252f16ec31a829bd3 Mon Sep 17 00:00:00 2001 From: giaca Date: Tue, 19 Nov 2024 21:14:26 +0100 Subject: [PATCH 049/111] bug fix in get_bit and further tests that lead to fails --- src/cdomain/value/cdomains/intDomain.ml | 2 +- tests/unit/cdomains/intDomainTest.ml | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a97c5f055b..e31a31183a 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1231,7 +1231,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let make_lsb_bitmask pos = Ints_t.sub (make_bitone_msk pos) Ints_t.one let make_msb_bitmask pos = Ints_t.lognot @@ make_lsb_bitmask pos - let get_bit bf pos = Ints_t.logand Ints_t.one @@ Ints_t.shift_right bf (pos-1) + let get_bit bf pos = Ints_t.logand Ints_t.one @@ Ints_t.shift_right bf pos let set_bit ?(zero=false) bf pos = if zero then Ints_t.logand bf @@ make_bitzero_msk pos diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 992480a6be..6fdd1c0dc3 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -475,11 +475,15 @@ module I = IntDomain.SOverflowUnlifter (I) let test_shift_left _ = assert_shift_left ik [2] [1] [4]; - assert_shift_left ik [-2] [1] [-4] + assert_shift_left ik [-2] [1] [-4]; + assert_shift_left ik [1; 8; 16] [1; 2] [2; 4; 16; 32; 64]; + assert_shift_left ik [1; 16] [28; 31; 32; 33] [0; 1 lsr 28; 1 lsr 32; 1 lsr 32] let test_shift_right _ = assert_shift_right ik [4] [1] [2]; - assert_shift_right ik [-4] [1] [-2] + assert_shift_right ik [-4] [1] [-2]; + assert_shift_right ik [1; 8; 16] [1; 2] [0; 2; 4; 8]; + assert_shift_right ik [1; 16; Int.max_int] [16; 32; 64; 128] [0; 16; Sys.word_size] (* TODO *) (* Arith *) From 65621615440cbcb147fb9ec979dff5249413626a Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 19 Nov 2024 23:27:28 +0100 Subject: [PATCH 050/111] clean up --- src/cdomain/value/cdomains/intDomain.ml | 158 ++++++++++++------------ src/framework/control.ml | 2 +- tests/unit/cdomains/intDomainTest.ml | 14 +-- 3 files changed, 87 insertions(+), 87 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a97c5f055b..c1efa08802 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1199,7 +1199,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask - + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) @@ -1249,7 +1249,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let break_down_lsb ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_invalid (z,o) then None else let rec break_down c_lst i = if i < 0 then c_lst - else + else if get_bit z i = get_bit o i then List.fold_left2 ( fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc @@ -1263,8 +1263,8 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let sufx_msk = make_lsb_bitmask lsb_bitcnt_log_ik in let msb_msk = Ints_t.logand (bits_set (z,o)) pfx_msk in (* shift a b = zero when min{b} > ceil(ilog2 a) *) if Ints_t.compare msb_msk Ints_t.zero = 0 - then break_down [(Ints_t.logand z pfx_msk, Ints_t.logand o sufx_msk)] (lsb_bitcnt_log_ik - 1) |> Option.some - else Some ([of_int @@ Ints_t.of_int (lsb_bitcnt_log_ik)]) + then break_down [(Ints_t.logand z pfx_msk, Ints_t.logand o sufx_msk)] (lsb_bitcnt_log_ik - 1) |> Option.some + else Some ([of_int @@ Ints_t.of_int (lsb_bitcnt_log_ik)]) let break_down ik bf = Option.map (fun c_bf_lst -> List.map snd c_bf_lst |> List.map Ints_t.to_int) (break_down_lsb ik bf) @@ -1281,53 +1281,53 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let shift_left ik bf n_bf = let shift_left (z,o) c = - let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one c) Ints_t.one in - (Ints_t.logor (Ints_t.shift_left z c) z_msk, Ints_t.shift_left o c) + let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one c) Ints_t.one in + (Ints_t.logor (Ints_t.shift_left z c) z_msk, Ints_t.shift_left o c) in if is_const n_bf then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) - - let min ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - - if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - let max ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else - + + let min ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + + if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + let max ik (z,o) = + let knownBitMask = Ints_t.logxor z o in + let unknownBitMask = Ints_t.lognot knownBitMask in + let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in + let guaranteedBits = Ints_t.logand o knownBitMask in + + if impossibleBitMask <> zero_mask then + failwith "Impossible bitfield" + else + let (_,fullMask) = Size.range ik in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - + if isSigned ik then Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) else Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - - let one = of_int Ints_t.one - let zero = of_int Ints_t.zero - let top_bool = join one zero - + + + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero + end module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct @@ -1343,24 +1343,24 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if BArith.is_invalid (z,o) then ((z,o), {underflow=false; overflow=false}) else - let (min_ik, max_ik) = Size.range ik in + let (min_ik, max_ik) = Size.range ik in - let (min,max) = range ik (z,o) in - let underflow = Z.compare min min_ik < 0 in - let overflow = Z.compare max max_ik > 0 in - - let new_bitfield= - (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik))) in - (newz,newo) - else - let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in - (newz,newo)) - in - if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) - else (new_bitfield, {underflow=underflow; overflow=overflow}) + let (min,max) = range ik (z,o) in + let underflow = Z.compare min min_ik < 0 in + let overflow = Z.compare max max_ik > 0 in + + let new_bitfield= + (if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo)) + in + if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) + else (new_bitfield, {underflow=underflow; overflow=overflow}) let top () = (BArith.one_mask, BArith.one_mask) let bot () = (BArith.zero_mask, BArith.zero_mask) @@ -1391,8 +1391,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) let to_int (z,o) = if is_bot (z,o) then None else - if BArith.is_const (z,o) then Some o - else None + if BArith.is_const (z,o) then Some o + else None let equal_to i bf = if BArith.of_int i = bf then `Eq @@ -1435,7 +1435,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let c_logor = log2 (||) ~annihilator:true let c_logand = log2 (&&) ~annihilator:false - + let c_lognot ik i1 = log1 not ik i1 @@ -1521,10 +1521,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor o1 o2)) bitmask in for i = size downto 0 do (if Ints_t.logand !pm Ints_t.one == Ints_t.one then - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) - else if Ints_t.logand !pv Ints_t.one == Ints_t.one then - accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) + else if Ints_t.logand !pv Ints_t.one == Ints_t.one then + accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); pv := Ints_t.shift_right !pv 1; pm := Ints_t.shift_right !pm 1; @@ -1545,10 +1545,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rem ik x y = M.trace "bitfield" "rem"; if BArith.is_const x && BArith.is_const y then ( - (* x % y = x - (x / y) * y *) - let tmp = fst (div ik x y) in - let tmp = fst (mul ik tmp y) in - fst (sub ik x tmp)) + (* x % y = x - (x / y) * y *) + let tmp = fst (div ik x y) in + let tmp = fst (mul ik tmp y) in + fst (sub ik x tmp)) else top_of ik let eq ik x y = @@ -1625,10 +1625,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in match bf, cong with | (z,o), Some (c, m) when is_power_of_two m -> - let congruenceMask = Ints_t.lognot m in - let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in - let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - norm ik (newz, newo) |> fst + let congruenceMask = Ints_t.lognot m in + let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in + let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + norm ik (newz, newo) |> fst | _ -> norm ik bf |> fst let refine_with_interval ik bf (int: (int_t * int_t) option) : t = @@ -1641,12 +1641,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_incl_list ik t (incl : (int_t list) option) : t = let joined =match incl with - | None -> top_of ik - | Some ls -> - List.fold_left (fun acc i -> BArith.join acc (BArith.of_int i)) (bot_of ik) ls + | None -> top_of ik + | Some ls -> + List.fold_left (fun acc i -> BArith.join acc (BArith.of_int i)) (bot_of ik) ls in meet ik t joined - + let arbitrary ik = let open QCheck.Iter in let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in @@ -1655,7 +1655,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int | (z, o) -> (GobQCheck.shrink int_arb z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb o >|= fun o -> (z, o)) in QCheck.(set_shrink shrink @@ set_print show @@ map (fun i -> of_int ik i |> fst ) int_arb) - (* QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (join ik (fst (of_int ik i1)) (fst (of_int ik i2))) |> fst ) pair_arb)*) + (* QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (join ik (fst (of_int ik i1)) (fst (of_int ik i2))) |> fst ) pair_arb)*) let project ik p t = t end diff --git a/src/framework/control.ml b/src/framework/control.ml index 1d0ebb869b..82c197273c 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -380,7 +380,7 @@ struct let test_domain (module D: Lattice.S): unit = let module DP = DomainProperties.All (D) in Logs.debug "domain testing...: %s" (D.name ()); - let errcode = QCheck_base_runner.run_tests DP.tests in + let errcode = QCheck_base_runner.run_tests DP.tests ~verbose:true in if (errcode <> 0) then failwith "domain tests failed" in diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 992480a6be..5b56e433d4 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -252,7 +252,7 @@ end module BitfieldTest (I : IntDomain.SOverflow with type int_t = Z.t) = struct -module I = IntDomain.SOverflowUnlifter (I) + module I = IntDomain.SOverflowUnlifter (I) let ik = Cil.IInt @@ -407,7 +407,7 @@ module I = IntDomain.SOverflowUnlifter (I) let test_cast_to _ = let b1 = I.of_int ik (of_int 1234) in - + assert_equal (I.of_int IChar (of_int (210))) (I.cast_to IChar b1); assert_equal (I.of_int ISChar (of_int (-46))) (I.cast_to ISChar b1); @@ -449,7 +449,7 @@ module I = IntDomain.SOverflowUnlifter (I) assert_bool "13 ?= 13 or (5 | 17)" (I.equal_to (of_int 13) (I.logor ik b12 b3) = `Top); assert_bool "29 ?= 13 or (5 | 17)" (I.equal_to (of_int 29) (I.logor ik b12 b3) = `Top) - let test_lognot _ = + let test_lognot _ = let b1 = I.of_int ik (of_int 4) in let b2 = I.of_int ik (of_int 12) in @@ -528,7 +528,7 @@ module I = IntDomain.SOverflowUnlifter (I) let b6 = I.of_int ik (of_int 4) in assert_bool "4 <= (5 | 14)" (I.le ik b6 b12 = I.of_bool ik true) - + let test_ge _ = let b1 = I.of_int ik (of_int 5) in let b2 = I.of_int ik (of_int 14) in @@ -671,7 +671,7 @@ module I = IntDomain.SOverflowUnlifter (I) "test_refine_with_congruence" >:: test_refine_with_congruence; "test_refine_with_inclusion_list" >:: test_refine_with_inclusion_list; - ] + ] end @@ -752,7 +752,7 @@ struct module B = IntDomain.SOverflowUnlifter (B) let ik = Cil.IUChar - let of_list ik is = List.fold_left (fun acc x -> B.join ik acc (B.of_int ik x)) (B.bot ()) is + let of_list ik is = List.fold_left (fun acc x -> B.join ik acc (B.of_int ik x)) (B.bot ()) is let v1 = Z.of_int 0 let v2 = Z.of_int 13 @@ -769,7 +769,7 @@ struct let test () = [ "test_add" >:: test_add; - ] + ] end module TEMPDEBUG_TODO_REMOVE = TEMPDEBUG_TODO_REMOVE_TEST(IntDomain.Bitfield) From 2aa27f8e76faaa5b7bcab146dd31acfcc06e0778 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 20 Nov 2024 00:31:52 +0100 Subject: [PATCH 051/111] fix compile warnings --- src/cdomain/value/cdomains/intDomain.ml | 202 ++++-------------------- 1 file changed, 30 insertions(+), 172 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c1efa08802..d7ea336042 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -17,11 +17,7 @@ exception ArithmeticOnIntegerBot of string (* Custom Tuple6 as Batteries only provides up to Tuple5 *) module Tuple6 = struct - type ('a,'b,'c,'d,'e,'f) t = 'a * 'b * 'c * 'd * 'e * 'f - type 'a enumerable = 'a * 'a * 'a * 'a * 'a * 'a - - let make a b c d e f= (a, b, c, d, e, f) let first (a,_,_,_,_, _) = a let second (_,b,_,_,_, _) = b @@ -30,23 +26,7 @@ module Tuple6 = struct let fifth (_,_,_,_,e, _) = e let sixth (_,_,_,_,_, f) = f - let map f1 f2 f3 f4 f5 f6 (a,b,c,d,e,f) = - let a = f1 a in - let b = f2 b in - let c = f3 c in - let d = f4 d in - let e = f5 e in - let f = f6 f in - (a, b, c, d, e, f) - - let mapn fn (a,b,c,d,e,f) = - let a = fn a in - let b = fn b in - let c = fn c in - let d = fn d in - let e = fn e in - let f = fn f in - (a, b, c, d, e, f) + let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) @@ -56,106 +36,24 @@ module Tuple6 = struct let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) - - - let curry fn a b c d e f= fn (a,b,c,d,e,f) - let uncurry fn (a,b,c,d,e,f) = fn a b c d e f - let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) - let of_enum e = match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some a -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some b -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some c -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some d -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some e -> match BatEnum.get e with - None -> failwith "Tuple6.of_enum: not enough elements" - | Some f -> (a,b,c,d,e,f) - - let print ?(first="(") ?(sep=",") ?(last=")") print_a print_b print_c print_d print_e print_f out (a,b,c,d,e,f) = - BatIO.nwrite out first; - print_a out a; - BatIO.nwrite out sep; - print_b out b; - BatIO.nwrite out sep; - print_c out c; - BatIO.nwrite out sep; - print_d out d; - BatIO.nwrite out sep; - print_e out e; - BatIO.nwrite out sep; - print_f out f - BatIO.nwrite out last - - - let printn ?(first="(") ?(sep=",") ?(last=")") printer out pair = - print ~first ~sep ~last printer printer printer printer printer out pair - - let compare ?(cmp1=Pervasives.compare) ?(cmp2=Pervasives.compare) ?(cmp3=Pervasives.compare) ?(cmp4=Pervasives.compare) ?(cmp5=Pervasives.compare) ?(cmp6=Pervasives.compare) (a1,a2,a3,a4,a5,a6) (b1,b2,b3,b4,b5,b6) = - let c1 = cmp1 a1 b1 in - if c1 <> 0 then c1 else - let c2 = cmp2 a2 b2 in - if c2 <> 0 then c2 else - let c3 = cmp3 a3 b3 in - if c3 <> 0 then c3 else - let c4 = cmp4 a4 b4 in - if c4 <> 0 then c4 else - let c5 = cmp5 a5 b5 in - if c5 <> 0 then c5 else - cmp5 a6 b6 - - open BatOrd - let eq eq1 eq2 eq3 eq4 eq5 eq6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_eq eq1 t1 t1' - (bin_eq eq2 t2 t2' - (bin_eq eq3 t3 t3' - (bin_eq eq4 t4 t4' - (bin_eq eq5 t5 t5' eq6)))) t6 t6' - - let ord ord1 ord2 ord3 ord4 ord5 ord6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - bin_ord ord1 t1 t1' - (bin_ord ord2 t2 t2' - (bin_ord ord3 t3 t3' - (bin_ord ord4 t4 t4' - (bin_ord ord5 t5 t5' ord6)))) t6 t6' - - let comp comp1 comp2 comp3 comp4 comp5 comp6 = - fun (t1, t2, t3, t4, t5,t6) (t1', t2', t3', t4', t5',t6') -> - let c1 = comp1 t1 t1' in - if c1 <> 0 then c1 else - let c2 = comp2 t2 t2' in - if c2 <> 0 then c2 else - let c3 = comp3 t3 t3' in - if c3 <> 0 then c3 else - let c4 = comp4 t4 t4' in - if c4 <> 0 then c4 else - let c5 = comp5 t5 t5' in - if c5 <> 0 then c5 else - comp6 t6 t6' - - module Eq (A : Eq) (B : Eq) (C : Eq) (D : Eq) (E : Eq) (F : Eq) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let eq = eq A.eq B.eq C.eq D.eq E.eq F.eq - end - - module Ord (A : Ord) (B : Ord) (C : Ord) (D : Ord) (E : Ord ) (F : Ord) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let ord = ord A.ord B.ord C.ord D.ord E.ord F.ord - end - - module Comp (A : Comp) (B : Comp) (C : Comp) (D : Comp) (E : Comp ) (F : Comp) = struct - type t = A.t * B.t * C.t * D.t * E.t * F.t - let compare = comp A.compare B.compare C.compare D.compare E.compare F.compare - end end +(* Prevent compile warnings *) +let _ = Tuple6.first +let _ = Tuple6.second +let _ = Tuple6.third +let _ = Tuple6.fourth +let _ = Tuple6.fifth +let _ = Tuple6.sixth + +let _ = Tuple6.map1 +let _ = Tuple6.map2 +let _ = Tuple6.map3 +let _ = Tuple6.map4 +let _ = Tuple6.map5 +let _ = Tuple6.map6 (** Define records that hold mutable variables representing different Configuration values. @@ -1194,8 +1092,6 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let of_int x = (Ints_t.lognot x, x) - let one = of_int Ints_t.one - let zero = of_int Ints_t.zero let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask @@ -1203,12 +1099,14 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero let bits_known (z,o) = Ints_t.logxor z o let bits_unknown bf = Ints_t.lognot @@ bits_known bf let bits_set bf = Ints_t.logand (snd bf) @@ bits_known bf - let bits_undef (z,o) = Ints_t.lognot (Ints_t.logxor z o) let is_const (z,o) = (Ints_t.logxor z o) = one_mask let is_invalid (z,o) = Ints_t.compare (Ints_t.lognot (Ints_t.logor z o)) Ints_t.zero != 0 @@ -1288,45 +1186,28 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let min ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in + let unknownBitMask = bits_unknown (z,o) in + let guaranteedBits = bits_set (z,o) in - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else if isSigned ik then let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) else - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask zero_mask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + Size.cast ik (Ints_t.to_bigint guaranteedBits ) let max ik (z,o) = - let knownBitMask = Ints_t.logxor z o in - let unknownBitMask = Ints_t.lognot knownBitMask in - let impossibleBitMask = Ints_t.lognot (Ints_t.logor z o) in - let guaranteedBits = Ints_t.logand o knownBitMask in - - if impossibleBitMask <> zero_mask then - failwith "Impossible bitfield" - else + let unknownBitMask = bits_unknown (z,o) in + let guaranteedBits = bits_set (z,o) in let (_,fullMask) = Size.range ik in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - if isSigned ik then - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - let one = of_int Ints_t.one - let zero = of_int Ints_t.zero - let top_bool = join one zero + end @@ -1402,9 +1283,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_interval ?(suppress_ovwarn=false) ik (x,y) = (* naive implentation -> horrible O(n) runtime *) let (min_ik, max_ik) = Size.range ik in - let current = ref (Z.of_int (Ints_t.to_int x)) in + let current = ref (Z.max (Z.of_int (Ints_t.to_int x)) min_ik) in let bf = ref (bot ()) in - while Z.leq !current (Z.of_int (Ints_t.to_int y)) do + while Z.leq !current (Z.min (Z.of_int (Ints_t.to_int y)) max_ik) do bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); current := Z.add !current Z.one done; @@ -1519,7 +1400,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let signBitUndef = Ints_t.logor signBitUndef1 signBitUndef2 in let signBitDefO = Ints_t.logand (Ints_t.logxor o1 o2) bitmask in let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor o1 o2)) bitmask in - for i = size downto 0 do + for _ = size downto 0 do (if Ints_t.logand !pm Ints_t.one == Ints_t.one then accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) else if Ints_t.logand !pv Ints_t.one == Ints_t.one then @@ -1538,7 +1419,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if isSigned ik then o3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefO !o3); norm ik (!z3, !o3) - let rec div ?no_ov ik (z1, o1) (z2, o2) = + let div ?no_ov ik (z1, o1) (z2, o2) = let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = Ints_t.div z1 z2 in (Ints_t.lognot tmp, tmp)) else top_of ik in norm ik res @@ -1600,26 +1481,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (norm ~suppress_ovwarn ik @@ (top ())) - let refine_with_congruence ik (intv : t) ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in - match intv, cong with - | (z,o), Some (c, m) -> - if is_power_of_two m then - let congruenceMask = Ints_t.lognot m in - let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in - let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in - norm ik (newz, newo) |> fst - else - top_of ik - | _ -> top_of ik - - let refine_with_interval ik t i = norm ik t |> fst - - let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst - let invariant_ikind e ik = - M.trace "bitfield" "invariant_ikind"; - failwith "Not implemented" let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in @@ -1631,13 +1493,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik (newz, newo) |> fst | _ -> norm ik bf |> fst - let refine_with_interval ik bf (int: (int_t * int_t) option) : t = - M.trace "bitfield" "refine_with_interval"; - norm ik bf |> fst + let refine_with_interval ik t i = norm ik t |> fst - let refine_with_excl_list ik bf (excl : (int_t list * (int64 * int64)) option) : t = - M.trace "bitfield" "refine_with_excl_list"; - norm ik bf |> fst + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst let refine_with_incl_list ik t (incl : (int_t list) option) : t = let joined =match incl with From ad5f6f8ca89f5bdeb07a6cb61e9d2b022cfcb71a Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 20 Nov 2024 00:33:30 +0100 Subject: [PATCH 052/111] format --- src/cdomain/value/cdomains/intDomain.ml | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index d7ea336042..4a9b803788 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1,5 +1,5 @@ -open GobConfig open GoblintCil +open GobConfig open Pretty open PrecisionUtil @@ -18,7 +18,6 @@ exception ArithmeticOnIntegerBot of string (* Custom Tuple6 as Batteries only provides up to Tuple5 *) module Tuple6 = struct - let first (a,_,_,_,_, _) = a let second (_,b,_,_,_, _) = b let third (_,_,c,_,_, _) = c @@ -26,8 +25,6 @@ module Tuple6 = struct let fifth (_,_,_,_,e, _) = e let sixth (_,_,_,_,_, f) = f - - let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) @@ -35,7 +32,6 @@ module Tuple6 = struct let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) - let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) end @@ -1186,10 +1182,9 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let min ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in + let unknownBitMask = bits_unknown (z,o) in let guaranteedBits = bits_set (z,o) in - if isSigned ik then let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in @@ -1201,13 +1196,10 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let unknownBitMask = bits_unknown (z,o) in let guaranteedBits = bits_set (z,o) in - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - - + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) end From cfa009193ca358708ef2ac51164f855b7dd1dccb Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 20 Nov 2024 00:36:48 +0100 Subject: [PATCH 053/111] improve arbitrary --- src/cdomain/value/cdomains/intDomain.ml | 59 ++++++++++++++----------- 1 file changed, 33 insertions(+), 26 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4a9b803788..751171eb92 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1086,12 +1086,11 @@ end (* Bitfield arithmetic, without any overflow handling etc. *) module BitfieldArith (Ints_t : IntOps.IntOps) = struct - let of_int x = (Ints_t.lognot x, x) - - let zero_mask = Ints_t.zero let one_mask = Ints_t.lognot zero_mask + let of_int x = (Ints_t.lognot x, x) + let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) @@ -1210,11 +1209,27 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int module BArith = BitfieldArith (Ints_t) + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = top () + let bot_of ik = bot () + + let show t = + if t = bot () then "bot" else + if t = top () then "top" else + let (z,o) = t in + if BArith.is_const t then + Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) + else + Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + let range ik bf = (BArith.min ik bf, BArith.max ik bf) let norm ?(suppress_ovwarn=false) ik (z,o) = if BArith.is_invalid (z,o) then - ((z,o), {underflow=false; overflow=false}) + (bot (), {underflow=false; overflow=false}) else let (min_ik, max_ik) = Size.range ik in @@ -1235,21 +1250,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) else (new_bitfield, {underflow=underflow; overflow=overflow}) - let top () = (BArith.one_mask, BArith.one_mask) - let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = (norm ik (top ())) |> fst - let bot_of ik = bot () - - let show t = - if t = bot () then "bot" else - if t = top () then "top" else - let (z,o) = t in - if BArith.is_const t then - Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) - else - Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst @@ -1473,8 +1473,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (norm ~suppress_ovwarn ik @@ (top ())) - - let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in match bf, cong with @@ -1500,12 +1498,21 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let arbitrary ik = let open QCheck.Iter in let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - (*let pair_arb = QCheck.pair int_arb int_arb in*) - let shrink = function - | (z, o) -> (GobQCheck.shrink int_arb z >|= fun z -> (z, o)) <+> (GobQCheck.shrink int_arb o >|= fun o -> (z, o)) + let pair_arb = QCheck.pair int_arb int_arb in + let shrink (z, o) = + (GobQCheck.shrink pair_arb (z, o) + >|= (fun (new_z, new_o) -> + (* Randomly flip bits to be opposite *) + let random_mask = Ints_t.of_int64 (Random.int64 (Int64.of_int (Size.bits ik |> snd))) in + let unsure_bitmask= Ints_t.logand new_z new_o in + let canceled_bits=Ints_t.logand unsure_bitmask random_mask in + let flipped_z = Ints_t.logor new_z canceled_bits in + let flipped_o = Ints_t.logand new_o (Ints_t.lognot canceled_bits) in + norm ik (flipped_z, flipped_o) |> fst + )) in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun i -> of_int ik i |> fst ) int_arb) - (* QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (join ik (fst (of_int ik i1)) (fst (of_int ik i2))) |> fst ) pair_arb)*) + + QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (i1,i2) |> fst ) pair_arb) let project ik p t = t end From 59146952bb60503bd463910e8707d64b74ba20e3 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 20 Nov 2024 00:45:54 +0100 Subject: [PATCH 054/111] fix bug after merge --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 730a156257..18eebd968f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1239,8 +1239,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let new_bitfield= (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik))) in + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik - 1))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik - 1))) in (newz,newo) else let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in From 15f7abeb9e2188b501fab73c3ab3fd7022c7502b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Thu, 21 Nov 2024 22:19:00 +0100 Subject: [PATCH 055/111] changed narrow and added unit tests for arith ops --- src/cdomain/value/cdomains/intDomain.ml | 2 +- tests/unit/cdomains/intDomainTest.ml | 86 +++++++++++++++++++++++++ 2 files changed, 87 insertions(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 18eebd968f..de5f437696 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1259,7 +1259,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - let narrow ik x y = norm ik x |> fst + let narrow ik x y = meet ik x y let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 9a4392548d..795c1be9d9 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -487,6 +487,85 @@ struct (* Arith *) + let print_err_message bf1 bf2 bfr = + I.show bfr ^ " on input " ^ I.show bf1 ^ " and " ^ I.show bf2 + + let ik_arithu = Cil.IUChar + + let ik_ariths = Cil.IChar + + let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is + + let result_list op is1 is2 = List.concat (List.map (fun x -> List.map (op x) is2) is1) + + let generate_test ?(debug=false) opc opa ik is1 is2 = + let zs1 = List.map Z.of_int is1 in + let zs2 = List.map Z.of_int is2 in + let res = of_list ik (result_list opc zs1 zs2) in + let bs1 = of_list ik zs1 in + let bs2 = of_list ik zs2 in + let bsr = opa ik bs1 bs2 in + OUnit2.assert_equal ~cmp:I.leq ~printer:(print_err_message bs1 bs2) res bsr + + let c1 = [99] + let c2 = [186] + let c3 = [-64] + let c4 = [-104] + + let is1 = [8; 45; 89; 128] + let is2 = [5; 69; 72; 192] + let is3 = [-11; -42; -99; -120] + let is4 = [-16; -64; -87; -111] + let is5 = [-64; -14; 22; 86] + + let testsuite = [c1;c2;c3;c4;is1;is2;is3;is4] + let testsuite_unsigned = [c1;c2;is1;is2] + + let arith_testsuite ?(debug=false) opc opa ts ik = + List.map (fun x -> List.map (generate_test opc opa ik x) ts) ts + + let test_add _ = + let _ = arith_testsuite Z.add I.add testsuite ik_arithu in + let _ = arith_testsuite Z.add I.add testsuite ik_ariths in + () + + let test_sub _ = + let _ = arith_testsuite Z.sub I.sub testsuite ik_arithu in + let _ = arith_testsuite Z.sub I.sub testsuite ik_ariths in + () + + let test_mul _ = + let _ = arith_testsuite Z.mul I.mul testsuite ik_arithu in + let _ = arith_testsuite Z.mul I.mul testsuite ik_ariths in + () + + let test_div _ = + let _ = arith_testsuite Z.div I.div testsuite_unsigned ik_arithu in + let _ = arith_testsuite Z.div I.div testsuite IShort in + () + + let test_rem _ = + let _ = arith_testsuite Z.rem I.rem testsuite_unsigned ik_arithu in + let _ = arith_testsuite Z.rem I.rem testsuite IShort in + () + + let test_neg _ = + let print_neg_err_message bfi bfr = + I.show bfr ^ " on input " ^ I.show bfi + in + let generate_test_neg opc opa ik is = + let zs = List.map Z.of_int is in + let res = of_list ik (List.map opc zs) in + let bs = of_list ik zs in + OUnit2.assert_equal ~cmp:I.leq ~printer:(print_neg_err_message bs) res (opa ik bs) + in + let neg_testsuite opc opa ik = + let testsuite = [c1;c2;c3;c4;is1;is2;is3;is4] in + List.map (generate_test_neg opc opa ik) testsuite + in + let _ = neg_testsuite Z.neg I.neg ik_arithu in + let _ = neg_testsuite Z.neg I.neg ik_ariths in + () (* Comparisons *) @@ -663,6 +742,13 @@ struct "test_shift_left" >:: test_shift_left; "test_shift_right" >:: test_shift_right; + "test_add" >:: test_add; + "test_sub" >:: test_sub; + "test_mul" >:: test_mul; + "test_div" >:: test_div; + "test_rem" >:: test_rem; + + "test_eq" >:: test_eq; "test_ne" >:: test_ne; "test_le" >:: test_le; From f9f7fce57400618a0d9701e93b015abc96a2b32c Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Sun, 24 Nov 2024 15:40:00 +0100 Subject: [PATCH 056/111] add some regression tests --- src/cdomain/value/cdomains/intDomain.ml | 24 ++++++- tests/regression/01-cpa/76-bitfield.c | 36 ----------- .../82-bitfield/00-simple-mask-bitfield.c | 29 +++++++++ .../regression/82-bitfield/01-simple-arith.c | 13 ++++ .../regression/82-bitfield/02-complex-arith.c | 62 +++++++++++++++++++ .../82-bitfield/03-simple-bitwise.c | 14 +++++ 6 files changed, 140 insertions(+), 38 deletions(-) delete mode 100644 tests/regression/01-cpa/76-bitfield.c create mode 100644 tests/regression/82-bitfield/00-simple-mask-bitfield.c create mode 100644 tests/regression/82-bitfield/01-simple-arith.c create mode 100644 tests/regression/82-bitfield/02-complex-arith.c create mode 100644 tests/regression/82-bitfield/03-simple-bitwise.c diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index de5f437696..283724e096 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1101,6 +1101,9 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bits_known (z,o) = Ints_t.logxor z o let bits_unknown bf = Ints_t.lognot @@ bits_known bf + + let bits_impossible (z,o) = Ints_t.lognot @@ Ints_t.logor z o + let bits_set bf = Ints_t.logand (snd bf) @@ bits_known bf let is_const (z,o) = (Ints_t.logxor z o) = one_mask @@ -1214,14 +1217,31 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let top_of ik = top () let bot_of ik = bot () + let to_pretty_bits (z,o) = + let known = BArith.bits_known (z,o) in + let impossible = BArith.bits_impossible (z,o) in + + let max_bits = 16 in + + let rec to_pretty_bits' known_mask impossible_mask o_mask max_bits acc = + if max_bits < 0 || o_mask = Ints_t.zero then acc + else + let current_bit_known = Ints_t.logand known_mask Ints_t.one in + let current_bit_impossible = Ints_t.logand impossible_mask Ints_t.one in + let value = Ints_t.logand o_mask Ints_t.one in + let acc' = (if current_bit_impossible = Ints_t.one then "⊥" else if current_bit_known = Ints_t.one then string_of_int (Ints_t.to_int value) else "⊤") ^ acc in + to_pretty_bits' (Ints_t.shift_right known_mask 1) (Ints_t.shift_right impossible_mask 1) (Ints_t.shift_right o_mask 1) (max_bits - 1) acc' + in + to_pretty_bits' known impossible o max_bits "" + let show t = if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in if BArith.is_const t then - Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) + Format.sprintf "{%d, %d} {%s} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (to_pretty_bits t) (Ints_t.to_int o) else - Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) + Format.sprintf "{%d, %d} {%s}" (Ints_t.to_int z) (Ints_t.to_int o) (to_pretty_bits t) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) diff --git a/tests/regression/01-cpa/76-bitfield.c b/tests/regression/01-cpa/76-bitfield.c deleted file mode 100644 index 2125895d18..0000000000 --- a/tests/regression/01-cpa/76-bitfield.c +++ /dev/null @@ -1,36 +0,0 @@ -//PARAM: --enable ana.int.bitfield -#include -#include -#include - -#define ANY_ERROR 5 // 5 -int main() { - int testvar = 235; - - int state; - int r = rand() % 3; // {r 7→ [0; 2],state 7→ [MIN INT; MAX INT]} - switch (r) { - case 0: - state = 0; /* 0 */ - testvar = 1; - break; - case 1: - state = 8; /* 8 */ - testvar = 1; - break; - default: - state = 10; /* 10 */ - testvar = 1; - break; - } - - if(state & ANY_ERROR == 0) { - printf("Error\n"); - } else { - printf("No error\n"); - } - - // {r 7→ [0; 2],state 7→ [0; 10]} - assert((state & ANY_ERROR) == 0); - __goblint_check((state & ANY_ERROR) == 0); -} diff --git a/tests/regression/82-bitfield/00-simple-mask-bitfield.c b/tests/regression/82-bitfield/00-simple-mask-bitfield.c new file mode 100644 index 0000000000..f5ea8dd79f --- /dev/null +++ b/tests/regression/82-bitfield/00-simple-mask-bitfield.c @@ -0,0 +1,29 @@ +// PARAM: --enable ana.int.bitfield +#include +#include +#include + +#define ANY_ERROR 5 // 0b0101 + +int main() { + int testvar = 235; + + int state; + int r = rand() % 3; + switch (r) { + case 0: + state = 0; /* 0b000 */ + testvar = 1; + break; + case 1: + state = 8; /* 0b1000 */ + testvar = 1; + break; + default: + state = 10; /* 0b1010 */ + testvar = 1; + break; + } + + __goblint_check((state & ANY_ERROR) == 0); +} diff --git a/tests/regression/82-bitfield/01-simple-arith.c b/tests/regression/82-bitfield/01-simple-arith.c new file mode 100644 index 0000000000..4fa963eb51 --- /dev/null +++ b/tests/regression/82-bitfield/01-simple-arith.c @@ -0,0 +1,13 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a = 19; + int b = 23; + + __goblint_check(a + b == 42); + __goblint_check(a - b == -4); + __goblint_check(a * b == 437); + __goblint_check(a / b == 0); + __goblint_check(a % b == 19); +} diff --git a/tests/regression/82-bitfield/02-complex-arith.c b/tests/regression/82-bitfield/02-complex-arith.c new file mode 100644 index 0000000000..b6de6028b7 --- /dev/null +++ b/tests/regression/82-bitfield/02-complex-arith.c @@ -0,0 +1,62 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a; + int b = 23; + + int r = rand() % 2; + switch (r) { + case 0: + a = 19; + printf("a = 19\n"); + break; + default: + a = 17; + printf("a = 17\n"); + break; + } + + // PLUS + + int c_add = a + b; + + if (c_add == 40) { + __goblint_check(1); // reachable + } + if (c_add == 42) { + __goblint_check(1); // reachable + } + if (c_add > 42 || c_add < 40) { + __goblint_check(0); // NOWARN (unreachable) + } + + // MINUS + + int c_minus = b - a; + + if (c_minus == 6) { + __goblint_check(1); // reachable + } + if (c_minus == 4) { + __goblint_check(1); // reachable + } + if (c_minus > 6 || c_minus < 4) { + __goblint_check(0); // NOWARN (unreachable) + } + + // MULT + + int c_mult = a * b; + + if (c_mult == 391) { + __goblint_check(1); // reachable + } + if (c_mult == 437) { + __goblint_check(1); // reachable + } + + // DIV + + // Div on non-unique bitfields is not supported +} diff --git a/tests/regression/82-bitfield/03-simple-bitwise.c b/tests/regression/82-bitfield/03-simple-bitwise.c new file mode 100644 index 0000000000..8f4f809ba2 --- /dev/null +++ b/tests/regression/82-bitfield/03-simple-bitwise.c @@ -0,0 +1,14 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a = 19; + int b = 14; + + __goblint_check((a & b) == 2); + __goblint_check((a | b) == 31); + __goblint_check((a ^ b) == 29); + __goblint_check((~a) == -20); + __goblint_check((a << 2) == 76); + __goblint_check((a >> 2) == 4); +} From 1b6459d441345aa315f0e0fcb90b60a08e49ed3d Mon Sep 17 00:00:00 2001 From: giaca Date: Mon, 25 Nov 2024 07:34:25 +0100 Subject: [PATCH 057/111] reworked bitfield shifts, infix operators and some simple tests. signedness info in type necessary for maximal and minimal func? --- src/cdomain/value/cdomains/intDomain.ml | 188 ++++++++++++------------ tests/unit/cdomains/intDomainTest.ml | 65 ++++---- 2 files changed, 134 insertions(+), 119 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index de5f437696..75f61f6253 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1086,104 +1086,104 @@ end (* Bitfield arithmetic, without any overflow handling etc. *) module BitfieldArith (Ints_t : IntOps.IntOps) = struct + let (&:) = Ints_t.logand + let (|:) = Ints_t.logor + let (^:) = Ints_t.logxor + let (!:) = Ints_t.lognot + let (<<:) = Ints_t.shift_left + let (>>:) = Ints_t.shift_right + (* Shift-in ones *) + let ( >>. ) = fun a b -> Ints_t.shift_right a b |: !:(Ints_t.sub (Ints_t.one <<: b) Ints_t.one) + let (<:) = fun a b -> Ints_t.compare a b < 0 + let (=:) = fun a b -> Ints_t.compare a b = 0 + let zero_mask = Ints_t.zero - let one_mask = Ints_t.lognot zero_mask + let one_mask = !:zero_mask - let of_int x = (Ints_t.lognot x, x) + let of_int x = (!:x, x) - let join (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) - let meet (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logand o1 o2) + let join (z1,o1) (z2,o2) = (z1 |: z2, o1 |: o2) + let meet (z1,o1) (z2,o2) = (z1 &: z2, o1 &: o2) let one = of_int Ints_t.one let zero = of_int Ints_t.zero - let top_bool = join one zero - let bits_known (z,o) = Ints_t.logxor z o - let bits_unknown bf = Ints_t.lognot @@ bits_known bf - let bits_set bf = Ints_t.logand (snd bf) @@ bits_known bf + let bits_known (z,o) = z ^: o + let bits_unknown bf = !:(bits_known bf) + let bits_set bf = snd bf &: bits_known bf - let is_const (z,o) = (Ints_t.logxor z o) = one_mask - let is_invalid (z,o) = Ints_t.compare (Ints_t.lognot (Ints_t.logor z o)) Ints_t.zero != 0 + let is_const (z,o) = (z ^: o) =: one_mask + let is_invalid (z,o) = not ((!:(z |: o)) =: Ints_t.zero) - let nabla x y= if x = Ints_t.logor x y then x else one_mask + let nabla x y= if x =: (x |: y) then x else one_mask let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) let lognot (z,o) = (o,z) - let logxor (z1,o1) (z2,o2) = (Ints_t.logor (Ints_t.logand z1 z2) (Ints_t.logand o1 o2), - Ints_t.logor (Ints_t.logand z1 o2) (Ints_t.logand o1 z2)) + let logxor (z1,o1) (z2,o2) = ((z1 &: z2) |: (o1 &: o2), + (z1 &: o2) |: (o1 &: z2)) - let logand (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logand o1 o2) + let logand (z1,o1) (z2,o2) = (z1 |: z2, o1 &: o2) - let logor (z1,o1) (z2,o2) = (Ints_t.logand z1 z2, Ints_t.logor o1 o2) + let logor (z1,o1) (z2,o2) = (z1 &: z2, o1 |: o2) - let make_bitone_msk pos = Ints_t.shift_left Ints_t.one pos - let make_bitzero_msk pos = Ints_t.lognot @@ make_bitone_msk pos - let make_lsb_bitmask pos = Ints_t.sub (make_bitone_msk pos) Ints_t.one - let make_msb_bitmask pos = Ints_t.lognot @@ make_lsb_bitmask pos + let make_bitone_msk pos = Ints_t.one <<: pos + let make_bitzero_msk pos = !:(make_bitone_msk pos) + let make_lsb_bitmask pos = + let bitmsk = make_bitone_msk pos in + if bitmsk =: Ints_t.zero then Ints_t.zero + else Ints_t.sub bitmsk Ints_t.one + let make_msb_bitmask pos = !:(make_lsb_bitmask pos) - let get_bit bf pos = Ints_t.logand Ints_t.one @@ Ints_t.shift_right bf pos - let set_bit ?(zero=false) bf pos = - if zero then - Ints_t.logand bf @@ make_bitzero_msk pos + let get_bit bf pos = Ints_t.one &: (bf <<: pos) + + (* Worst Case asymptotic runtime: O(2^n). *) + let rec concretize (z,o) = + if is_const (z,o) then [o] else - Ints_t.logor bf @@ make_bitone_msk pos + let arbitrary_bit = (z ^: o) &: (z |: o) &: Ints_t.one in + let bit = o &: Ints_t.one in + let shifted_z, shifted_o = (z >>. 1, o >>: 1) in + if not (arbitrary_bit =: Ints_t.zero) + then concretize (shifted_z, shifted_o) |> List.concat_map (fun c -> [c <<: 1; (c <<: 1) |: Ints_t.one]) + else concretize (shifted_z, shifted_o) |> List.map (fun c -> c <<: 1 |: bit) + + let concretize bf = List.map Ints_t.to_int (concretize bf) - let log2_bitcnt ik = - let ilog2 n = - let rec aux n acc = - if n <= 1 then acc - else aux (n lsr 1) (acc + 1) - in aux n 0 - in ilog2 (Size.bit ik) + let get_c (_,o) = Ints_t.to_int o - let break_down_lsb ik (z,o) : (Ints_t.t * Ints_t.t) list option = if is_invalid (z,o) then None + let shift_right ik (z,o) c = + let sign_msk = make_msb_bitmask (Size.bit ik - c) in + if (isSigned ik) && (o <: Ints_t.zero) then + (z <<: c, (o <<: c) |: sign_msk) else - let rec break_down c_lst i = if i < 0 then c_lst - else - if get_bit z i = get_bit o i then - List.fold_left2 ( - fun acc (z1,o1) (z2,o2) -> (set_bit z1 i, set_bit ~zero:true o1 i) :: (set_bit ~zero:true z2 i, o2) :: acc - ) [] c_lst c_lst - |> fun c_lst -> break_down c_lst (i-1) - else - break_down c_lst (i-1) - in - let lsb_bitcnt_log_ik = log2_bitcnt ik + 1 in (* ilog2 bitcnt of ik ceiled *) - let pfx_msk = make_msb_bitmask lsb_bitcnt_log_ik in - let sufx_msk = make_lsb_bitmask lsb_bitcnt_log_ik in - let msb_msk = Ints_t.logand (bits_set (z,o)) pfx_msk in (* shift a b = zero when min{b} > ceil(ilog2 a) *) - if Ints_t.compare msb_msk Ints_t.zero = 0 - then break_down [(Ints_t.logand z pfx_msk, Ints_t.logand o sufx_msk)] (lsb_bitcnt_log_ik - 1) |> Option.some - else Some ([of_int @@ Ints_t.of_int (lsb_bitcnt_log_ik)]) - - let break_down ik bf = Option.map (fun c_bf_lst -> List.map snd c_bf_lst |> List.map Ints_t.to_int) (break_down_lsb ik bf) - - let shift_right ik bf n_bf = - let shift_right (z,o) c = - let sign_msk = Ints_t.shift_left one_mask (Size.bit ik - c) in - if (isSigned ik) && ((Ints_t.to_int o) < 0) then - (Ints_t.shift_right z c, Ints_t.logor (Ints_t.shift_right o c) sign_msk) - else - (Ints_t.logor (Ints_t.shift_right z c) sign_msk, Ints_t.shift_right o c) - in - if is_const n_bf then Some (shift_right bf (Ints_t.to_int @@ snd n_bf)) - else Option.map (fun c_lst -> List.map (shift_right bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) + ((z <<: c) |: sign_msk, o <<: c) - let shift_left ik bf n_bf = - let shift_left (z,o) c = - let z_msk = Ints_t.sub (Ints_t.shift_left Ints_t.one c) Ints_t.one in - (Ints_t.logor (Ints_t.shift_left z c) z_msk, Ints_t.shift_left o c) - in - if is_const n_bf then Some (shift_left bf (Ints_t.to_int @@ snd n_bf)) - else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) + let shift_right ik bf possible_shifts = + if is_const possible_shifts then shift_right ik bf (get_c possible_shifts) + else + let join_shrs c_lst = List.map (shift_right ik bf) c_lst |> List.fold_left join zero in + let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in + concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + |> join_shrs + + let shift_left _ (z,o) c = + let z_msk = make_lsb_bitmask c in + ((z <<: c) |: z_msk, o <<: c) + + let shift_left ik bf possible_shifts = + if is_const possible_shifts then shift_left ik bf (get_c possible_shifts) + else + let join_shls c_lst = List.map (shift_left ik bf) c_lst |> List.fold_left join zero in + let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in + concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + |> join_shls let min ik (z,o) = let unknownBitMask = bits_unknown (z,o) in let guaranteedBits = bits_set (z,o) in - if isSigned ik then let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in @@ -1194,10 +1194,8 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let max ik (z,o) = let unknownBitMask = bits_unknown (z,o) in let guaranteedBits = bits_set (z,o) in - let (_,fullMask) = Size.range ik in let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) end @@ -1226,26 +1224,28 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let range ik bf = (BArith.min ik bf, BArith.max ik bf) + let minimal bf = Option.some (BArith.bits_known bf) (* TODO signedness info in type? No ik here! *) + let maximal bf = BArith.(bits_known bf |: bits_unknown bf) |> Option.some (* TODO signedness info in type? No ik here! *) let norm ?(suppress_ovwarn=false) ik (z,o) = if BArith.is_invalid (z,o) then (bot (), {underflow=false; overflow=false}) else let (min_ik, max_ik) = Size.range ik in - + let wrap ik (z,o) = + if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik - 1))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik - 1))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo) + in let (min,max) = range ik (z,o) in let underflow = Z.compare min min_ik < 0 in let overflow = Z.compare max max_ik > 0 in - - let new_bitfield= - (if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik - 1))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik - 1))) in - (newz,newo) - else - let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in - (newz,newo)) + let new_bitfield = wrap ik (z,o) in if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) else (new_bitfield, {underflow=underflow; overflow=overflow}) @@ -1273,12 +1273,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else `Neq let of_interval ?(suppress_ovwarn=false) ik (x,y) = - (* naive implentation -> horrible O(n) runtime *) let (min_ik, max_ik) = Size.range ik in - let current = ref (Z.max (Z.of_int (Ints_t.to_int x)) min_ik) in - let bf = ref (bot ()) in - while Z.leq !current (Z.min (Z.of_int (Ints_t.to_int y)) max_ik) do - bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); + let current = ref (Z.max (Ints_t.to_bigint x) min_ik) in + let bf = ref (bot ()) in + while Z.leq !current (Z.min (Ints_t.to_bigint y) max_ik) do + bf := BArith.join !bf (BArith.of_int @@ Ints_t.of_bigint !current); current := Z.add !current Z.one done; norm ~suppress_ovwarn ik !bf @@ -1324,11 +1323,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - norm ik @@ (BArith.shift_right ik a b |> Option.value ~default: (bot ())) + if BArith.is_invalid b || BArith.is_invalid a then (bot (), {underflow=false; overflow=false}) + else norm ik (BArith.shift_right ik a b) let shift_left ik a b = M.trace "bitfield" "shift_left"; - norm ik @@ (BArith.shift_left ik a b |> Option.value ~default: (bot ())) + if BArith.is_invalid b || BArith.is_invalid a then (bot (), {underflow=false; overflow=false}) + else norm ik (BArith.shift_left ik a b) (* Arith *) @@ -1424,7 +1425,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int fst (sub ik x tmp)) else top_of ik - let eq ik x y = + let eq ik x y = if (BArith.max ik x) <= (BArith.min ik y) && (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true else if (BArith.min ik x) > (BArith.max ik y) || (BArith.max ik x) < (BArith.min ik y) then of_bool ik false else BArith.top_bool @@ -1455,7 +1456,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let starting ?(suppress_ovwarn=false) ik n = if Ints_t.compare n Ints_t.zero >= 0 then (* sign bit can only be 0, as all numbers will be positive *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in let zs = BArith.one_mask in let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in (norm ~suppress_ovwarn ik @@ (zs,os)) @@ -1465,7 +1466,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let ending ?(suppress_ovwarn=false) ik n = if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then (* sign bit can only be 1, as all numbers will be negative *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in let os = BArith.one_mask in (norm ~suppress_ovwarn ik @@ (zs,os)) @@ -1511,7 +1512,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik (flipped_z, flipped_o) |> fst )) in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (i1,i2) |> fst ) pair_arb) let project ik p t = t diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 795c1be9d9..7acccbccd9 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -289,10 +289,10 @@ struct let b1 = I.of_int ik (of_int 9) in let b2 = I.of_int ik (of_int 2) in let bjoin = I.join ik b1 b2 in + assert_bool "num1 leq join" (I.leq b1 bjoin); assert_bool "num2 leq join" (I.leq b2 bjoin); - OUnit.assert_equal `Top (I.equal_to (Z.of_int 9) bjoin); OUnit.assert_equal `Top (I.equal_to (Z.of_int 2) bjoin); OUnit.assert_equal `Top (I.equal_to (Z.of_int 11) bjoin) @@ -373,14 +373,20 @@ struct (* no widening needed *) assert_bool "join leq widen" (I.leq (I.join ik b1 b2) (I.widen ik b1 b2)) - let test_of_interval _ = - let intvl= (of_int 3, of_int 17) in - let b1 = I.of_interval ik intvl in - - for i = 3 to 17 do - assert_bool (string_of_int i) (I.equal_to (of_int i) b1 = `Top) + let assert_of_interval lb ub = + let intvl = (of_int lb, of_int ub) in + let bf = I.of_interval ik intvl in + let print_err_message i = "Missing value: " ^ string_of_int i ^ " in [" ^ string_of_int lb ^ ", " ^ string_of_int ub ^ "]" in + for i = lb to ub do + assert_bool (print_err_message i) (I.equal_to (of_int i) bf = `Top) done + let test_of_interval _ = + assert_of_interval 3 17; + assert_of_interval (-17) (-3); + assert_of_interval (-3) 17; + assert_of_interval (-17) 3 + let test_of_bool _ = let b1 = I.of_bool ik true in let b2 = I.of_bool ik false in @@ -460,30 +466,37 @@ struct assert_bool "-13 ?= not (4 | 12)" (I.equal_to (of_int (-13)) (I.lognot ik b12) = `Top); assert_bool "-5 ?= not (4 | 12)" (I.equal_to (of_int (-5)) (I.lognot ik b12) = `Top) - (* TODO assumes join to be correct *) + let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is + let assert_shift shift symb ik a b res = - let lst2bf lst = List.map (fun x -> I.of_int ik @@ of_int x) lst |> List.fold_left (I.join ik) (I.bot ()) in - let stat1 = lst2bf a in - let stat2 = lst2bf b in - let eval = (shift ik stat1 stat2) in - let eq = lst2bf res in - let out_string = I.show stat1 ^ symb ^ I.show stat2 ^ " should be : \"" ^ I.show eq ^ "\" but was \"" ^ I.show eval ^ "\"" in - OUnit2.assert_equal ~cmp:(fun x y -> Option.value ~default:false @@ I.to_bool @@ I.eq ik x y) ~msg:out_string eq eval (* TODO msg *) + let bs1 = of_list ik (List.map of_int a) in + let bs2 = of_list ik (List.map of_int b) in + let bsr = of_list ik (List.map of_int res) in + let res = (shift ik bs1 bs2) in + let test_case_str = I.show bs1 ^ symb ^ I.show bs2 in + OUnit.assert_equal ~cmp:I.leq ~printer:I.show ~msg:test_case_str bsr res (*bsr <= res!*) - let assert_shift_left ik a b res = assert_shift I.shift_left "<<" ik a b res - let assert_shift_right ik a b res = assert_shift I.shift_right ">>" ik a b res + let assert_shift_left ik a b res = assert_shift I.shift_left " << " ik a b res + let assert_shift_right ik a b res = assert_shift I.shift_right " >> " ik a b res let test_shift_left _ = assert_shift_left ik [2] [1] [4]; assert_shift_left ik [-2] [1] [-4]; - assert_shift_left ik [1; 8; 16] [1; 2] [2; 4; 16; 32; 64]; - assert_shift_left ik [1; 16] [28; 31; 32; 33] [0; 1 lsr 28; 1 lsr 32; 1 lsr 32] + assert_shift_left ik [2; 16] [1; 2] [4; 8; 32; 64]; + assert_shift_left ik [-2; 16] [1; 2] [-8; -4; 32; 64]; + assert_shift_left ik [2; -16] [1; 2] [-64; -32; 4; 8]; + assert_shift_left ik [-2; -16] [1; 2] [-64; -32; -8; -4]; + assert_shift_left ik [-3; 5; -7; 11] [2; 5] [-224; -96; -28; -12; 20; 44; 160; 352] let test_shift_right _ = assert_shift_right ik [4] [1] [2]; assert_shift_right ik [-4] [1] [-2]; - assert_shift_right ik [1; 8; 16] [1; 2] [0; 2; 4; 8]; - assert_shift_right ik [1; 16; Int.max_int] [16; 32; 64; 128] [0; 16; Sys.word_size] (* TODO *) + assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 8]; + assert_shift_right ik [-2; 16] [1; 2] [-1; 0; 4; 8]; + assert_shift_right ik [2; -16] [1; 2] [-8; -4; 0; 1]; + assert_shift_right ik [-2; -16] [1; 2] [-8; -4; -1; 0]; + assert_shift_right ik [-53; 17; -24; 48] [3; 7] [-6; -3; 0; 2; 9] + (* Arith *) @@ -494,8 +507,6 @@ struct let ik_ariths = Cil.IChar - let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is - let result_list op is1 is2 = List.concat (List.map (fun x -> List.map (op x) is2) is1) let generate_test ?(debug=false) opc opa ik is1 is2 = @@ -522,7 +533,7 @@ struct let testsuite_unsigned = [c1;c2;is1;is2] let arith_testsuite ?(debug=false) opc opa ts ik = - List.map (fun x -> List.map (generate_test opc opa ik x) ts) ts + List.iter (fun x -> List.iter (generate_test opc opa ik x) ts) ts let test_add _ = let _ = arith_testsuite Z.add I.add testsuite ik_arithu in @@ -649,7 +660,6 @@ struct let b1 = I.of_int ik (of_int 5) in let b2 = I.of_int ik (of_int 14) in - assert_bool "5 > 5" (I.gt ik b1 b1 = I.of_bool ik false); assert_bool "5 > 14" (I.gt ik b1 b2 = I.of_bool ik false); assert_bool "14 > 5" (I.gt ik b2 b1 = I.of_bool ik true); @@ -713,6 +723,10 @@ struct List.iter (fun i -> assert_bool (Z.to_string i) (I.equal_to i bf_refined = `Top)) list + (* + let test_refine_with_exclusion_list _ = failwith "TODO" + *) + let test () =[ "test_of_int_to_int" >:: test_of_int_to_int; "test_to_int_of_int" >:: test_to_int_of_int; @@ -761,6 +775,7 @@ struct "test_refine_with_congruence" >:: test_refine_with_congruence; "test_refine_with_inclusion_list" >:: test_refine_with_inclusion_list; + (*"test_refine_with_exclusion_list" >:: test_refine_with_exclusion_list;*) ] end From 31def4bf221b4ef454c5e1279c3f5d95ca31c7bb Mon Sep 17 00:00:00 2001 From: giaca Date: Mon, 25 Nov 2024 07:59:46 +0100 Subject: [PATCH 058/111] shift a b = zero when min{b} >= ceil(log (Size.bit ik)) --- src/cdomain/value/cdomains/intDomain.ml | 41 +++++++++++++------------ 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 75f61f6253..fe1534077b 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1139,6 +1139,24 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let get_bit bf pos = Ints_t.one &: (bf <<: pos) + let min ik (z,o) = + let unknownBitMask = bits_unknown (z,o) in + let guaranteedBits = bits_set (z,o) in + if isSigned ik then + let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + else + Size.cast ik (Ints_t.to_bigint guaranteedBits ) + + let max ik (z,o) = + let unknownBitMask = bits_unknown (z,o) in + let guaranteedBits = bits_set (z,o) in + let (_,fullMask) = Size.range ik in + let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in + Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + + (* Worst Case asymptotic runtime: O(2^n). *) let rec concretize (z,o) = if is_const (z,o) then [o] @@ -1166,7 +1184,8 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else let join_shrs c_lst = List.map (shift_right ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + if Z.to_int (min ik bf) >= max_bit then zero + else concretize (make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shrs let shift_left _ (z,o) c = @@ -1178,26 +1197,10 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else let join_shls c_lst = List.map (shift_left ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + if Z.to_int (min ik bf) >= max_bit then zero + else concretize (make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shls - let min ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in - let guaranteedBits = bits_set (z,o) in - if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint guaranteedBits ) - - let max ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in - let guaranteedBits = bits_set (z,o) in - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - end module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct From 2ba8f386ac03c228f5042c0243a8fcc025003b01 Mon Sep 17 00:00:00 2001 From: giaca Date: Mon, 25 Nov 2024 08:14:50 +0100 Subject: [PATCH 059/111] negative shifts are undefined --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index fe1534077b..f9ed4d0dbc 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1326,12 +1326,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - if BArith.is_invalid b || BArith.is_invalid a then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid b || BArith.is_invalid a || BArith.(min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_right ik a b) let shift_left ik a b = M.trace "bitfield" "shift_left"; - if BArith.is_invalid b || BArith.is_invalid a then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid b || BArith.is_invalid a || BArith.(min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_left ik a b) (* Arith *) From b6762af8d59976d9d82cb9bcba2acf5489e77068 Mon Sep 17 00:00:00 2001 From: giaca Date: Mon, 25 Nov 2024 08:18:31 +0100 Subject: [PATCH 060/111] bugfix: zero bits for lsb bitmask --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index f9ed4d0dbc..61b80dd843 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1185,7 +1185,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join_shrs c_lst = List.map (shift_right ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in if Z.to_int (min ik bf) >= max_bit then zero - else concretize (make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + else concretize (make_msb_bitmask max_bit |: fst bf, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shrs let shift_left _ (z,o) c = @@ -1198,7 +1198,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join_shls c_lst = List.map (shift_left ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in if Z.to_int (min ik bf) >= max_bit then zero - else concretize (make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + else concretize (make_msb_bitmask max_bit |: fst bf, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shls end From b6ee7fa64fa49834d4bb83e79a2c266ceacc17c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Mon, 25 Nov 2024 21:34:28 +0100 Subject: [PATCH 061/111] refactored min and max --- src/cdomain/value/cdomains/intDomain.ml | 36 +++++++++++-------------- tests/unit/cdomains/intDomainTest.ml | 8 +++--- 2 files changed, 20 insertions(+), 24 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index de5f437696..a9a96e3a35 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1181,24 +1181,18 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else Option.map (fun c_lst -> List.map (shift_left bf) c_lst |> List.fold_left join zero) (break_down ik n_bf) let min ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in - let guaranteedBits = bits_set (z,o) in - - if isSigned ik then - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask signBitMask in - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) - else - Size.cast ik (Ints_t.to_bigint guaranteedBits ) + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = Ints_t.logand signBit o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.to_bigint(Ints_t.logor signMask (Ints_t.lognot z)) + else Ints_t.to_bigint(Ints_t.lognot z) let max ik (z,o) = - let unknownBitMask = bits_unknown (z,o) in - let guaranteedBits = bits_set (z,o) in - - let (_,fullMask) = Size.range ik in - let worstPossibleUnknownBits = Ints_t.logand unknownBitMask (Ints_t.of_bigint fullMask) in - - Size.cast ik (Ints_t.to_bigint (Ints_t.logor guaranteedBits worstPossibleUnknownBits)) + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.to_bigint(Ints_t.logand signMask o) + else Ints_t.to_bigint o end @@ -1336,6 +1330,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int add, sub and mul based on the paper "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" of Vishwanathan et al. + https://doi.org/10.1109/CGO53902.2022.9741267 *) let add_paper pv pm qv qm = @@ -1394,10 +1389,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor o1 o2)) bitmask in for _ = size downto 0 do (if Ints_t.logand !pm Ints_t.one == Ints_t.one then - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) - else if Ints_t.logand !pv Ints_t.one == Ints_t.one then - accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) + else if Ints_t.logand !pv Ints_t.one == Ints_t.one then + accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); pv := Ints_t.shift_right !pv 1; pm := Ints_t.shift_right !pm 1; @@ -1445,7 +1440,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false else BArith.top_bool - let gt ik x y = lt ik y x let invariant_ikind e ik (z,o) = diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 795c1be9d9..1f5602e897 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -845,10 +845,10 @@ struct let of_list ik is = List.fold_left (fun acc x -> B.join ik acc (B.of_int ik x)) (B.bot ()) is let v1 = Z.of_int 0 - let v2 = Z.of_int 13 + let v2 = Z.of_int 2 let vr = Z.mul v1 v2 - let is = [0;1;2;3;4;5;6;7] + let is = [-3;3] let res = [0;13;26;39;52;65;78;91] let b1 = of_list ik (List.map Z.of_int is) @@ -857,8 +857,10 @@ struct let test_add _ = assert_equal ~cmp:B.leq ~printer:B.show br (B.mul ik b2 b1) + let test_lt _ = assert_equal ~cmp:B.leq ~printer:B.show (B.join ik (B.of_int ik Z.zero) (B.of_int ik Z.one)) (B.lt ik b1 b2) + let test () = [ - "test_add" >:: test_add; + "test_lt" >:: test_lt; ] end From e2366ffa58c4a4059058389effcf8a9ccf78ba40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 26 Nov 2024 11:54:49 +0100 Subject: [PATCH 062/111] added infix to all functions --- src/cdomain/value/cdomains/intDomain.ml | 150 +++++++++++++----------- 1 file changed, 83 insertions(+), 67 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5baf8c92b3..cc4e4c4310 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1138,17 +1138,17 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let get_bit bf pos = Ints_t.one &: (bf >>: pos) let min ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in - let isNegative = Ints_t.logand signBit o <> Ints_t.zero in - if isSigned ik && isNegative then Ints_t.to_bigint(Ints_t.logor signMask (Ints_t.lognot z)) - else Ints_t.to_bigint(Ints_t.lognot z) + let signBit = Ints_t.one <<: ((Size.bit ik) - 1) in + let signMask = !: (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = signBit &: o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.to_bigint(signMask |: (!: z)) + else Ints_t.to_bigint(!: z) let max ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signBit = Ints_t.one <<: ((Size.bit ik) - 1) in let signMask = Ints_t.of_bigint (snd (Size.range ik)) in - let isPositive = Ints_t.logand signBit z <> Ints_t.zero in - if isSigned ik && isPositive then Ints_t.to_bigint(Ints_t.logand signMask o) + let isPositive = signBit &: z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.to_bigint(signMask &: o) else Ints_t.to_bigint o (* Worst Case asymptotic runtime: O(2^n). *) @@ -1202,6 +1202,22 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int module BArith = BitfieldArith (Ints_t) + let (+:) = Ints_t.add + let (-:) = Ints_t.sub + let ( *: ) = Ints_t.mul + let (/:) = Ints_t.div + let (%:) = Ints_t.rem + let (&:) = Ints_t.logand + let (|:) = Ints_t.logor + let (^:) = Ints_t.logxor + let (!:) = Ints_t.lognot + let (<<:) = Ints_t.shift_left + let (>>:) = Ints_t.shift_right + (* Shift-in ones *) + let ( >>. ) = fun a b -> Ints_t.shift_right a b |: !:(Ints_t.sub (Ints_t.one <<: b) Ints_t.one) + let (<:) = fun a b -> Ints_t.compare a b < 0 + let (=:) = fun a b -> Ints_t.compare a b = 0 + let top () = (BArith.one_mask, BArith.one_mask) let bot () = (BArith.zero_mask, BArith.zero_mask) let top_of ik = top () @@ -1229,12 +1245,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let (min_ik, max_ik) = Size.range ik in let wrap ik (z,o) = if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit z (Size.bit ik - 1))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (BArith.get_bit o (Size.bit ik - 1))) in + let newz = (z &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit z (Size.bit ik - 1))) in + let newo = (o &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit o (Size.bit ik - 1))) in (newz,newo) else - let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + let newz = z |: !:(Ints_t.of_bigint max_ik) in + let newo = o &: (Ints_t.of_bigint max_ik) in (newz,newo) in let (min,max) = range ik (z,o) in @@ -1336,39 +1352,39 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int *) let add_paper pv pm qv qm = - let sv = Ints_t.add pv qv in - let sm = Ints_t.add pm qm in - let sigma = Ints_t.add sv sm in - let chi = Ints_t.logxor sigma sv in - let mu = Ints_t.logor (Ints_t.logor pm qm) chi in - let rv = Ints_t.logand sv (Ints_t.lognot mu) in + let sv = pv +: qv in + let sm = pm +: qm in + let sigma = sv +: sm in + let chi = sigma ^: sv in + let mu = pm |: qm |: chi in + let rv = sv &: !:mu in let rm = mu in (rv, rm) let add ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in + let pv = o1 &: !:z1 in + let pm = o1 &: z1 in + let qv = o2 &: !:z2 in + let qm = o2 &: z2 in let (rv, rm) = add_paper pv pm qv qm in - let o3 = Ints_t.logor rv rm in - let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + let o3 = rv |: rm in + let z3 = !:rv |: rm in norm ik (z3, o3) let sub ?no_ov ik (z1, o1) (z2, o2) = - let pv = Ints_t.logand o1 (Ints_t.lognot z1) in - let pm = Ints_t.logand o1 z1 in - let qv = Ints_t.logand o2 (Ints_t.lognot z2) in - let qm = Ints_t.logand o2 z2 in - let dv = Ints_t.sub pv qv in - let alpha = Ints_t.add dv pm in - let beta = Ints_t.sub dv qm in - let chi = Ints_t.logxor alpha beta in - let mu = Ints_t.logor (Ints_t.logor pm qm) chi in - let rv = Ints_t.logand dv (Ints_t.lognot mu) in + let pv = o1 &: !:z1 in + let pm = o1 &: z1 in + let qv = o2 &: !:z2 in + let qm = o2 &: z2 in + let dv = pv -: qv in + let alpha = dv +: pm in + let beta = dv -: qm in + let chi = alpha ^: beta in + let mu = pm |: qm |: chi in + let rv = dv &: !:mu in let rm = mu in - let o3 = Ints_t.logor rv rm in - let z3 = Ints_t.logor (Ints_t.lognot rv) rm in + let o3 = rv |: rm in + let z3 = !:rv |: rm in norm ik (z3, o3) let neg ?no_ov ik x = @@ -1376,40 +1392,40 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int sub ?no_ov ik BArith.zero x let mul ?no_ov ik (z1, o1) (z2, o2) = - let pm = ref (Ints_t.logand z1 o1) in - let pv = ref (Ints_t.logand o1 (Ints_t.lognot z1)) in - let qm = ref (Ints_t.logand z2 o2) in - let qv = ref (Ints_t.logand o2 (Ints_t.lognot z2)) in + let pm = ref (z1 &: o1) in + let pv = ref (o1 &: !:z1) in + let qm = ref (z2 &: o2) in + let qv = ref (o2 &: !:z2) in let accv = ref BArith.zero_mask in let accm = ref BArith.zero_mask in let size = if isSigned ik then Size.bit ik - 1 else Size.bit ik in let bitmask = Ints_t.of_bigint (fst (Size.range ik)) in - let signBitUndef1 = Ints_t.logand (Ints_t.logand z1 o1) bitmask in - let signBitUndef2 = Ints_t.logand (Ints_t.logand z2 o2) bitmask in - let signBitUndef = Ints_t.logor signBitUndef1 signBitUndef2 in - let signBitDefO = Ints_t.logand (Ints_t.logxor o1 o2) bitmask in - let signBitDefZ = Ints_t.logand (Ints_t.lognot (Ints_t.logxor o1 o2)) bitmask in + let signBitUndef1 = z1 &: o1 &: bitmask in + let signBitUndef2 = z2 &: o2 &: bitmask in + let signBitUndef = signBitUndef1 |: signBitUndef2 in + let signBitDefO = (o1 ^: o2) &: bitmask in + let signBitDefZ = !:(o1 ^: o2) &: bitmask in for _ = size downto 0 do - (if Ints_t.logand !pm Ints_t.one == Ints_t.one then - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (Ints_t.logor !qv !qm)) - else if Ints_t.logand !pv Ints_t.one == Ints_t.one then + (if !pm &: Ints_t.one == Ints_t.one then + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (!qv |: !qm)) + else if !pv &: Ints_t.one == Ints_t.one then accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); - pv := Ints_t.shift_right !pv 1; - pm := Ints_t.shift_right !pm 1; - qv := Ints_t.shift_left !qv 1; - qm := Ints_t.shift_left !qm 1; + pv := !pv >>: 1; + pm := !pm >>: 1; + qv := !qv <<: 1; + qm := !qm <<: 1; done; let (rv, rm) = add_paper !accv Ints_t.zero Ints_t.zero !accm in - let o3 = ref(Ints_t.logor rv rm) in - let z3 = ref(Ints_t.logor (Ints_t.lognot rv) rm) in - if isSigned ik then z3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefZ !z3); - if isSigned ik then o3 := Ints_t.logor signBitUndef (Ints_t.logor signBitDefO !o3); + let o3 = ref(rv |: rm) in + let z3 = ref(!:rv |: rm) in + if isSigned ik then z3 := signBitUndef |: signBitDefZ |: !z3; + if isSigned ik then o3 := signBitUndef |: signBitDefO |: !o3; norm ik (!z3, !o3) let div ?no_ov ik (z1, o1) (z2, o2) = - let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = Ints_t.div z1 z2 in (Ints_t.lognot tmp, tmp)) else top_of ik in + let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = z1 /: z2 in (!:tmp, tmp)) else top_of ik in norm ik res let rem ik x y = @@ -1453,7 +1469,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (* sign bit can only be 0, as all numbers will be positive *) let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in let zs = BArith.one_mask in - let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + let os = !:signBitMask &: BArith.one_mask in (norm ~suppress_ovwarn ik @@ (zs,os)) else (norm ~suppress_ovwarn ik @@ (top ())) @@ -1462,7 +1478,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then (* sign bit can only be 1, as all numbers will be negative *) let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in - let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in + let zs = !:signBitMask &: BArith.one_mask in let os = BArith.one_mask in (norm ~suppress_ovwarn ik @@ (zs,os)) else @@ -1470,12 +1486,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) in match bf, cong with | (z,o), Some (c, m) when is_power_of_two m -> - let congruenceMask = Ints_t.lognot m in - let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in - let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in + let congruenceMask = !:m in + let newz = (!:congruenceMask &: z) |: (congruenceMask &: !:c) in + let newo = (!:congruenceMask &: o) |: (congruenceMask &: c) in norm ik (newz, newo) |> fst | _ -> norm ik bf |> fst @@ -1500,10 +1516,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int >|= (fun (new_z, new_o) -> (* Randomly flip bits to be opposite *) let random_mask = Ints_t.of_int64 (Random.int64 (Int64.of_int (Size.bits ik |> snd))) in - let unsure_bitmask= Ints_t.logand new_z new_o in - let canceled_bits=Ints_t.logand unsure_bitmask random_mask in - let flipped_z = Ints_t.logor new_z canceled_bits in - let flipped_o = Ints_t.logand new_o (Ints_t.lognot canceled_bits) in + let unsure_bitmask= new_z &: new_o in + let canceled_bits= unsure_bitmask &: random_mask in + let flipped_z = new_z |: canceled_bits in + let flipped_o = new_o &: !:canceled_bits in norm ik (flipped_z, flipped_o) |> fst )) in From addda52226ba8db4abe5d0a19c1e4dcd4331b9ac Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 26 Nov 2024 12:41:44 +0100 Subject: [PATCH 063/111] extract tuple 6 from intDomain file --- src/cdomain/value/cdomains/intDomain.ml | 47 +++---------------------- src/util/std/gobTuple.ml | 37 +++++++++++++++++++ src/util/std/goblint_std.ml | 1 + 3 files changed, 42 insertions(+), 43 deletions(-) create mode 100644 src/util/std/gobTuple.ml diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index cc4e4c4310..9c8d378985 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -13,45 +13,6 @@ exception Unknown exception Error exception ArithmeticOnIntegerBot of string - - -(* Custom Tuple6 as Batteries only provides up to Tuple5 *) -module Tuple6 = struct - - let first (a,_,_,_,_, _) = a - let second (_,b,_,_,_, _) = b - let third (_,_,c,_,_, _) = c - let fourth (_,_,_,d,_, _) = d - let fifth (_,_,_,_,e, _) = e - let sixth (_,_,_,_,_, f) = f - - let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) - let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) - let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) - let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) - let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) - let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) - - let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) - -end - -(* Prevent compile warnings *) -let _ = Tuple6.first -let _ = Tuple6.second -let _ = Tuple6.third -let _ = Tuple6.fourth -let _ = Tuple6.fifth -let _ = Tuple6.sixth - -let _ = Tuple6.map1 -let _ = Tuple6.map2 -let _ = Tuple6.map3 -let _ = Tuple6.map4 -let _ = Tuple6.map5 -let _ = Tuple6.map6 - - (** Define records that hold mutable variables representing different Configuration values. * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) type ana_int_config_values = { @@ -3776,8 +3737,8 @@ module IntDomTupleImpl = struct let name () = "intdomtuple" (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) - let no_interval = Tuple6.map2 (const None) - let no_intervalSet = Tuple6.map5 (const None) + let no_interval = GobTuple.Tuple6.map2 (const None) + let no_intervalSet = GobTuple.Tuple6.map5 (const None) type 'a m = (module SOverflow with type t = 'a) type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) @@ -3836,7 +3797,7 @@ module IntDomTupleImpl = struct let opt_map2 f ?no_ov = curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None - let to_list x = Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) + let to_list x = GobTuple.Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) let exists = function @@ -4097,7 +4058,7 @@ module IntDomTupleImpl = struct (* fp: projections *) let equal_to i x = - let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple6.enum |> List.of_enum |> List.filter_map identity in + let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> GobTuple.Tuple6.enum |> List.of_enum |> List.filter_map identity in if List.mem `Eq xs then `Eq else if List.mem `Neq xs then `Neq else `Top diff --git a/src/util/std/gobTuple.ml b/src/util/std/gobTuple.ml new file mode 100644 index 0000000000..8edd970974 --- /dev/null +++ b/src/util/std/gobTuple.ml @@ -0,0 +1,37 @@ +open Batteries + +(* Custom Tuple6 as Batteries only provides up to Tuple5 *) +module Tuple6 = struct + + let first (a,_,_,_,_, _) = a + let second (_,b,_,_,_, _) = b + let third (_,_,c,_,_, _) = c + let fourth (_,_,_,d,_, _) = d + let fifth (_,_,_,_,e, _) = e + let sixth (_,_,_,_,_, f) = f + + let map1 fn (a, b, c, d, e, f) = (fn a, b, c, d, e, f) + let map2 fn (a, b, c, d, e, f) = (a, fn b, c, d, e, f) + let map3 fn (a, b, c, d, e, f) = (a, b, fn c, d, e, f) + let map4 fn (a, b, c, d, e, f) = (a, b, c, fn d, e, f) + let map5 fn (a, b, c, d, e, f) = (a, b, c, d, fn e, f) + let map6 fn (a, b, c, d, e, f) = (a, b, c, d, e, fn f) + + let enum (a,b,c,d,e,f) = BatList.enum [a;b;c;d;e;f] (* Make efficient? *) + +end + +(* Prevent compile warnings *) +let _ = Tuple6.first +let _ = Tuple6.second +let _ = Tuple6.third +let _ = Tuple6.fourth +let _ = Tuple6.fifth +let _ = Tuple6.sixth + +let _ = Tuple6.map1 +let _ = Tuple6.map2 +let _ = Tuple6.map3 +let _ = Tuple6.map4 +let _ = Tuple6.map5 +let _ = Tuple6.map6 diff --git a/src/util/std/goblint_std.ml b/src/util/std/goblint_std.ml index 5b623ead30..98c8742c0c 100644 --- a/src/util/std/goblint_std.ml +++ b/src/util/std/goblint_std.ml @@ -13,6 +13,7 @@ module GobResult = GobResult module GobOption = GobOption module GobSys = GobSys module GobUnix = GobUnix +module GobTuple = GobTuple (** {1 Other libraries} From 29bcca16c833515f1b70e6f30c7821541ba0a3a0 Mon Sep 17 00:00:00 2001 From: giaca Date: Tue, 26 Nov 2024 13:01:32 +0100 Subject: [PATCH 064/111] bugfix: shift_right did not shift right --- src/cdomain/value/cdomains/intDomain.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index cc4e4c4310..08d0c75bf4 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1092,7 +1092,6 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let (!:) = Ints_t.lognot let (<<:) = Ints_t.shift_left let (>>:) = Ints_t.shift_right - (* Shift-in ones *) let ( >>. ) = fun a b -> Ints_t.shift_right a b |: !:(Ints_t.sub (Ints_t.one <<: b) Ints_t.one) let (<:) = fun a b -> Ints_t.compare a b < 0 let (=:) = fun a b -> Ints_t.compare a b = 0 @@ -1111,6 +1110,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bits_known (z,o) = z ^: o let bits_unknown bf = !:(bits_known bf) + let bits_set bf = (snd bf) &: (bits_known bf) let is_const (z,o) = (z ^: o) =: one_mask let is_invalid (z,o) = not ((!:(z |: o)) =: Ints_t.zero) @@ -1169,9 +1169,9 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let shift_right ik (z,o) c = let sign_msk = make_msb_bitmask (Size.bit ik - c) in if (isSigned ik) && (o <: Ints_t.zero) then - (z <<: c, (o <<: c) |: sign_msk) + (z >>: c, (o >>: c) |: sign_msk) else - ((z <<: c) |: sign_msk, o <<: c) + ((z >>: c) |: sign_msk, o >>: c) let shift_right ik bf possible_shifts = if is_const possible_shifts then shift_right ik bf (get_c possible_shifts) From ed1999a14abd21b50fc5b8d597f7cc00d18b5b91 Mon Sep 17 00:00:00 2001 From: giaca Date: Tue, 26 Nov 2024 22:07:58 +0100 Subject: [PATCH 065/111] small QoL improvements and bug fixes --- src/cdomain/value/cdomains/intDomain.ml | 37 +++++++++++++++---------- tests/unit/cdomains/intDomainTest.ml | 22 +++++---------- 2 files changed, 29 insertions(+), 30 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 1535eee09a..8723dc25dd 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1090,15 +1090,17 @@ module BitfieldInfixOps (Ints_t : IntOps.IntOps) = struct let (!:) = Ints_t.lognot let (<<:) = Ints_t.shift_left let (>>:) = Ints_t.shift_right - let ( >>. ) = fun a b -> Ints_t.shift_right a b |: !:(Ints_t.sub (Ints_t.one <<: b) Ints_t.one) let (<:) = fun a b -> Ints_t.compare a b < 0 let (=:) = fun a b -> Ints_t.compare a b = 0 + let (>:) = fun a b -> Ints_t.compare a b > 0 let (+:) = Ints_t.add let (-:) = Ints_t.sub let ( *: ) = Ints_t.mul let (/:) = Ints_t.div let (%:) = Ints_t.rem + + let (>>.) = fun a b -> a >>: b |: !:((Ints_t.one <<: b) -: Ints_t.one) end (* Bitfield arithmetic, without any overflow handling etc. *) @@ -1119,7 +1121,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let top_bool = join one zero let bits_known (z,o) = z ^: o - let bits_unknown bf = !:(bits_known bf) + let bits_unknown (z,o) = z &: o let bits_set bf = (snd bf) &: (bits_known bf) let bits_invalid (z,o) = !:(z |: o) @@ -1166,16 +1168,16 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let rec concretize (z,o) = if is_const (z,o) then [o] else - let arbitrary_bit = (z ^: o) &: (z |: o) &: Ints_t.one in + let is_bit_unknown = not ((bits_unknown (z,o) &: Ints_t.one) =: Ints_t.zero) in let bit = o &: Ints_t.one in let shifted_z, shifted_o = (z >>. 1, o >>: 1) in - if not (arbitrary_bit =: Ints_t.zero) + if is_bit_unknown then concretize (shifted_z, shifted_o) |> List.concat_map (fun c -> [c <<: 1; (c <<: 1) |: Ints_t.one]) else concretize (shifted_z, shifted_o) |> List.map (fun c -> c <<: 1 |: bit) let concretize bf = List.map Ints_t.to_int (concretize bf) - let get_c (_,o) = Ints_t.to_int o + let get_o (_,o) = Ints_t.to_int o let shift_right ik (z,o) c = let sign_msk = make_msb_bitmask (Size.bit ik - c) in @@ -1185,11 +1187,12 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct ((z >>: c) |: sign_msk, o >>: c) let shift_right ik bf possible_shifts = - if is_const possible_shifts then shift_right ik bf (get_c possible_shifts) + if is_const possible_shifts then shift_right ik bf (get_o possible_shifts) else let join_shrs c_lst = List.map (shift_right ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + if Z.to_int (min ik bf) >= max_bit then zero + else concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shrs let shift_left _ (z,o) c = @@ -1197,11 +1200,12 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct ((z <<: c) |: z_msk, o <<: c) let shift_left ik bf possible_shifts = - if is_const possible_shifts then shift_left ik bf (get_c possible_shifts) + if is_const possible_shifts then shift_left ik bf (get_o possible_shifts) else let join_shls c_lst = List.map (shift_left ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + if Z.to_int (min ik bf) >= max_bit then zero + else concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shls end @@ -1224,9 +1228,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let to_pretty_bits (z,o) = let known_bits = BArith.bits_known (z,o) in let invalid_bits = BArith.bits_invalid (z,o) in - let num_bits_to_print = 8 in + let num_bits_to_print = Sys.word_size in let rec to_pretty_bits' known_mask impossible_mask o_mask max_bits acc = - if o_mask = Ints_t.zero then "0" + if max_bits < 0 then + if o_mask = Ints_t.zero && String.empty = acc + then "0" else acc + else if o_mask = Ints_t.zero then acc else let current_bit_known = known_mask &: Ints_t.one in let current_bit_impossible = impossible_mask &: Ints_t.one in @@ -1236,7 +1243,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int then "⊥" else if current_bit_known = Ints_t.one || current_bit_known = Ints_t.zero then string_of_int (Ints_t.to_int bit_value) else "⊤" in - to_pretty_bits' (known_mask <<: 1) (impossible_mask <<: 1) (o_mask <<: 1) (max_bits - 1) (next_bit_string ^ acc) + to_pretty_bits' (known_mask >>: 1) (impossible_mask >>: 1) (o_mask >>: 1) (max_bits - 1) (next_bit_string ^ acc) in to_pretty_bits' known_bits invalid_bits o num_bits_to_print "" @@ -1251,7 +1258,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int with Z.Overflow -> max_num_unknown_bits_to_concretize + 1 in if num_bits_unknown > max_num_unknown_bits_to_concretize then - Format.sprintf "(%08X, %08X)" (Ints_t.to_int z) (Ints_t.to_int o) + Format.sprintf "(%016X, %016X)" (Ints_t.to_int z) (Ints_t.to_int o) else (* TODO: Might be a source of long running tests.*) BArith.concretize (z,o) |> List.map string_of_int |> String.concat "; " @@ -1365,12 +1372,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - if BArith.is_invalid b || BArith.is_invalid a then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_right ik a b) let shift_left ik a b = M.trace "bitfield" "shift_left"; - if BArith.is_invalid b || BArith.is_invalid a then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_left ik a b) (* Arith *) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 03d930ed19..7f9be62dbe 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -468,13 +468,13 @@ struct let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is - let assert_shift shift symb ik a b res = + let assert_shift shift symb ik a b expected_values = let bs1 = of_list ik (List.map of_int a) in let bs2 = of_list ik (List.map of_int b) in - let bsr = of_list ik (List.map of_int res) in - let res = (shift ik bs1 bs2) in - let test_case_str = I.show bs1 ^ symb ^ I.show bs2 in - OUnit.assert_equal ~cmp:I.leq ~printer:I.show ~msg:test_case_str bsr res (*bsr <= res!*) + let bf_shift_res = (shift ik bs1 bs2) in + let output_string = I.show bs1 ^ symb ^ I.show bs2 in + let output_string elm = "Test shift (bf" ^ symb ^ string_of_int elm ^ ") failed: " ^ output_string in + List.iter (fun v -> assert_bool (output_string v) (let test_result = I.equal_to (of_int v) bf_shift_res in test_result = `Top || test_result = `Eq)) expected_values let assert_shift_left ik a b res = assert_shift I.shift_left " << " ik a b res let assert_shift_right ik a b res = assert_shift I.shift_right " >> " ik a b res @@ -482,20 +482,12 @@ struct let test_shift_left _ = assert_shift_left ik [2] [1] [4]; assert_shift_left ik [-2] [1] [-4]; - assert_shift_left ik [2; 16] [1; 2] [4; 8; 32; 64]; - assert_shift_left ik [-2; 16] [1; 2] [-8; -4; 32; 64]; - assert_shift_left ik [2; -16] [1; 2] [-64; -32; 4; 8]; - assert_shift_left ik [-2; -16] [1; 2] [-64; -32; -8; -4]; - assert_shift_left ik [-3; 5; -7; 11] [2; 5] [-224; -96; -28; -12; 20; 44; 160; 352] + assert_shift_left ik [2; 16] [1; 2] [4; 8; 32; 64] let test_shift_right _ = assert_shift_right ik [4] [1] [2]; assert_shift_right ik [-4] [1] [-2]; - assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 8]; - assert_shift_right ik [-2; 16] [1; 2] [-1; 0; 4; 8]; - assert_shift_right ik [2; -16] [1; 2] [-8; -4; 0; 1]; - assert_shift_right ik [-2; -16] [1; 2] [-8; -4; -1; 0]; - assert_shift_right ik [-53; 17; -24; 48] [3; 7] [-6; -3; 0; 2; 9] + assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 8] (* Arith *) From 7fa010084dbfa7e19b5ce799cb9d6a816d79f59c Mon Sep 17 00:00:00 2001 From: giaca Date: Tue, 26 Nov 2024 22:13:44 +0100 Subject: [PATCH 066/111] bugfix: certain zeros and uncertain ones --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 8723dc25dd..5859b86f11 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1192,7 +1192,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join_shrs c_lst = List.map (shift_right ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in if Z.to_int (min ik bf) >= max_bit then zero - else concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + else concretize (fst bf |: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shrs let shift_left _ (z,o) c = @@ -1205,7 +1205,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let join_shls c_lst = List.map (shift_left ik bf) c_lst |> List.fold_left join zero in let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in if Z.to_int (min ik bf) >= max_bit then zero - else concretize (fst bf &: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) + else concretize (fst bf |: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) |> join_shls end From 96e5737c06a6096bf11ce145703781a84b649a05 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 27 Nov 2024 04:06:28 +0100 Subject: [PATCH 067/111] add regression test for refinement --- src/cdomain/value/cdomains/intDomain.ml | 23 ++++++++++++------- .../82-bitfield/05-refine-with-congruence.c | 15 ++++++++++++ tests/unit/cdomains/intDomainTest.ml | 4 +--- 3 files changed, 31 insertions(+), 11 deletions(-) create mode 100644 tests/regression/82-bitfield/05-refine-with-congruence.c diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 283724e096..299aff6152 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1232,16 +1232,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let acc' = (if current_bit_impossible = Ints_t.one then "⊥" else if current_bit_known = Ints_t.one then string_of_int (Ints_t.to_int value) else "⊤") ^ acc in to_pretty_bits' (Ints_t.shift_right known_mask 1) (Ints_t.shift_right impossible_mask 1) (Ints_t.shift_right o_mask 1) (max_bits - 1) acc' in - to_pretty_bits' known impossible o max_bits "" + "0b"^to_pretty_bits' known impossible o max_bits "" let show t = if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in - if BArith.is_const t then - Format.sprintf "{%d, %d} {%s} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (to_pretty_bits t) (Ints_t.to_int o) - else - Format.sprintf "{%d, %d} {%s}" (Ints_t.to_int z) (Ints_t.to_int o) (to_pretty_bits t) + Format.sprintf "{zs:%d, os:%d} %s" (Ints_t.to_int z) (Ints_t.to_int o) (to_pretty_bits t) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) @@ -1435,13 +1432,24 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = Ints_t.div z1 z2 in (Ints_t.lognot tmp, tmp)) else top_of ik in norm ik res + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) + let rem ik x y = - M.trace "bitfield" "rem"; if BArith.is_const x && BArith.is_const y then ( (* x % y = x - (x / y) * y *) let tmp = fst (div ik x y) in let tmp = fst (mul ik tmp y) in fst (sub ik x tmp)) + else if BArith.is_const y && is_power_of_two (snd y) then ( + let mask = Ints_t.sub (snd y) Ints_t.one in + print_endline (Ints_t.to_string mask); + print_endline (Ints_t.to_string (Ints_t.lognot mask)); + let newz = Ints_t.logor (fst x) (Ints_t.lognot mask) in + let newo = Ints_t.logand (snd x) mask in + print_endline (Ints_t.to_string newz); + print_endline (Ints_t.to_string newo); + norm ik (newz, newo) |> fst + ) else top_of ik let eq ik x y = @@ -1494,9 +1502,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) in match bf, cong with - | (z,o), Some (c, m) when is_power_of_two m -> + | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> let congruenceMask = Ints_t.lognot m in let newz = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) z) (Ints_t.logand congruenceMask (Ints_t.lognot c)) in let newo = Ints_t.logor (Ints_t.logand (Ints_t.lognot congruenceMask) o) (Ints_t.logand congruenceMask c) in diff --git a/tests/regression/82-bitfield/05-refine-with-congruence.c b/tests/regression/82-bitfield/05-refine-with-congruence.c new file mode 100644 index 0000000000..828bdfdb9f --- /dev/null +++ b/tests/regression/82-bitfield/05-refine-with-congruence.c @@ -0,0 +1,15 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield --set ana.int.refinement fixpoint --enable ana.int.congruence +#include +#include +#include + +int main() { + int a = rand(); + + __goblint_assume(a % 8 == 3); + + __goblint_assert((a & 0x7) == 3); // SUCCESS + +} + + \ No newline at end of file diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 795c1be9d9..8d82645dd2 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -700,9 +700,7 @@ struct let bf_refined1= I.refine_with_congruence ik bf (Some (Z.of_int 3, Z.of_int 4)) in assert_bool "3" (I.equal_to (of_int 3) bf_refined1 = `Top); - let bf_refined2= I.refine_with_congruence ik bf_refined1 (Some (Z.of_int 1, Z.of_int 1)) in - assert_bool "1" (I.equal_to (of_int 1) bf_refined2 = `Eq); - let bf_refined3= I.refine_with_congruence ik bf_refined2 (Some (Z.of_int 5, Z.of_int 0)) in + let bf_refined3= I.refine_with_congruence ik bf (Some (Z.of_int 5, Z.of_int 0)) in assert_bool "5" (I.equal_to (of_int 5) bf_refined3 = `Eq) let test_refine_with_inclusion_list _ = From 90338a731e424d9d91c9bc5f3b38db4dfba31dea Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 27 Nov 2024 18:51:43 +0100 Subject: [PATCH 068/111] add more regression tests for refines --- .../regression/82-bitfield/06-refine-with-incl-set.c | 12 ++++++++++++ .../regression/82-bitfield/07-refine-with-interval.c | 12 ++++++++++++ 2 files changed, 24 insertions(+) create mode 100644 tests/regression/82-bitfield/06-refine-with-incl-set.c create mode 100644 tests/regression/82-bitfield/07-refine-with-interval.c diff --git a/tests/regression/82-bitfield/06-refine-with-incl-set.c b/tests/regression/82-bitfield/06-refine-with-incl-set.c new file mode 100644 index 0000000000..6edd060c5c --- /dev/null +++ b/tests/regression/82-bitfield/06-refine-with-incl-set.c @@ -0,0 +1,12 @@ +// PARAM: --disable ana.int.def_exc --enable ana.int.bitfield --set ana.int.refinement fixpoint --enable ana.int.enums +#include +#include +#include + +int main() { + int a = rand(); + + if (a == 9 || a == 11 || a == 15) { + __goblint_assert((a & 9) == 9); // SUCCESS + } +} diff --git a/tests/regression/82-bitfield/07-refine-with-interval.c b/tests/regression/82-bitfield/07-refine-with-interval.c new file mode 100644 index 0000000000..f8b6159455 --- /dev/null +++ b/tests/regression/82-bitfield/07-refine-with-interval.c @@ -0,0 +1,12 @@ +// PARAM: --enable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield --set ana.int.refinement fixpoint +#include +#include +#include + +int main() { + int a = rand(); + + if (a <= 4) { + __goblint_assert((a & 0x10) == 0); // SUCCESS + } +} From f25a57804052f028740ac1014452b86521ea4825 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Thu, 28 Nov 2024 04:31:42 +0100 Subject: [PATCH 069/111] improve refine with interval; add regression tests --- src/cdomain/value/cdomains/intDomain.ml | 71 ++++++++++++------- .../82-bitfield/07-refine-with-interval.c | 13 ++++ 2 files changed, 58 insertions(+), 26 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 299aff6152..dd6298e42e 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1290,15 +1290,44 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else `Neq let of_interval ?(suppress_ovwarn=false) ik (x,y) = - (* naive implentation -> horrible O(n) runtime *) let (min_ik, max_ik) = Size.range ik in - let current = ref (Z.max (Z.of_int (Ints_t.to_int x)) min_ik) in - let bf = ref (bot ()) in - while Z.leq !current (Z.min (Z.of_int (Ints_t.to_int y)) max_ik) do - bf := BArith.join !bf (BArith.of_int (Ints_t.of_bigint !current)); - current := Z.add !current Z.one - done; - norm ~suppress_ovwarn ik !bf + let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in + let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in + + let rec analyze_bits pos (acc_z, acc_o) = + if pos < 0 then (acc_z, acc_o) + else + let position = Ints_t.shift_left Ints_t.one pos in + let mask = Ints_t.sub position Ints_t.one in + let remainder = Ints_t.logand startv mask in + + let without_remainder = Ints_t.sub startv remainder in + let bigger_number = Ints_t.add without_remainder position in + + let bit_status = + if Ints_t.compare bigger_number endv <= 0 then + `top + else + if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then + `one + else + `zero + in + + let new_acc = + match bit_status with + | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) + | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) + | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) + + in + analyze_bits (pos - 1) new_acc + in + + let result = analyze_bits (Size.bit ik - 1) (bot()) in + let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) in + norm ~suppress_ovwarn ik casted + let of_bool _ik = function true -> BArith.one | false -> BArith.zero @@ -1481,25 +1510,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int IntInvariant.of_interval e ik range let starting ?(suppress_ovwarn=false) ik n = - if Ints_t.compare n Ints_t.zero >= 0 then - (* sign bit can only be 0, as all numbers will be positive *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let zs = BArith.one_mask in - let os = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) + let (min_ik, max_ik) = Size.range ik in + of_interval ~suppress_ovwarn ik (n, Ints_t.of_bigint max_ik) let ending ?(suppress_ovwarn=false) ik n = - if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then - (* sign bit can only be 1, as all numbers will be negative *) - let signBitMask = Ints_t.shift_left Ints_t.one (Size.bit ik - 1) in - let zs = Ints_t.logand (Ints_t.lognot signBitMask) BArith.one_mask in - let os = BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) - + let (min_ik, max_ik) = Size.range ik in + of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = match bf, cong with @@ -1510,7 +1526,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik (newz, newo) |> fst | _ -> norm ik bf |> fst - let refine_with_interval ik t i = norm ik t |> fst + let refine_with_interval ik t itv = + match itv with + | None -> norm ik t |> fst + | Some (l, u) -> meet ik t (of_interval ik (l, u) |> fst) let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst diff --git a/tests/regression/82-bitfield/07-refine-with-interval.c b/tests/regression/82-bitfield/07-refine-with-interval.c index f8b6159455..3a4bc547fb 100644 --- a/tests/regression/82-bitfield/07-refine-with-interval.c +++ b/tests/regression/82-bitfield/07-refine-with-interval.c @@ -8,5 +8,18 @@ int main() { if (a <= 4) { __goblint_assert((a & 0x10) == 0); // SUCCESS + + int b = ~0x7; + __goblint_assert((a & b) == 0); // SUCCESS + } + + if (a > 8 && a < 15) { + __goblint_assert((a & 8) == 8); // SUCCESS + } + + int b = rand() - 512; + + if(-4 <= b && b <= -2) { + __goblint_assert((b & 4) == 4); // SUCCESS } } From e9286e798d8f6c159d03dc2d00811ca3e92d1db7 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 3 Dec 2024 09:54:26 +0100 Subject: [PATCH 070/111] fixed bitshifts --- src/cdomain/value/cdomains/intDomain.ml | 65 ++++++++++++++++++------- tests/unit/cdomains/intDomainTest.ml | 45 +++++++++++++++-- 2 files changed, 87 insertions(+), 23 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5859b86f11..c82ab8f549 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1179,7 +1179,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let get_o (_,o) = Ints_t.to_int o - let shift_right ik (z,o) c = + (* let shift_right ik (z,o) c = let sign_msk = make_msb_bitmask (Size.bit ik - c) in if (isSigned ik) && (o <: Ints_t.zero) then (z >>: c, (o >>: c) |: sign_msk) @@ -1206,7 +1206,50 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in if Z.to_int (min ik bf) >= max_bit then zero else concretize (fst bf |: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) - |> join_shls + |> join_shls *) + + + let shift_right_action ik (z,o) c = + let sign_msk = make_msb_bitmask (Size.bit ik - c) in + if (isSigned ik) && (o <: Ints_t.zero) then + (z >>: c, (o >>: c) |: sign_msk) + else + ((z >>: c) |: sign_msk, o >>: c) + + let shift_right ik (z1, o1) (z2, o2) = + if is_const (z2, o2) then shift_right_action ik (z1, o1) (Ints_t.to_int o2) + else + let max_bit = Z.log2up (Z.of_int (Size.bit ik)) in + let mask = !:(one_mask<<:max_bit) in + let concrete_values = concretize ((z2 &: mask), (o2 &: mask)) in + if (List.length concrete_values) == 0 then (one_mask, zero_mask) + else + let (v1, v2) = (ref zero_mask, ref zero_mask) in + List.iter (fun x -> let (a, b) = (shift_right_action ik (z1, o1) x) in + v1 := !v1 |: a; + v2 := !v2 |: b + ) concrete_values; + (!v1, !v2) + + let shift_left_action _ (z,o) c = + let z_msk = make_lsb_bitmask c in + ((z <<: c) |: z_msk, o <<: c) + + let shift_left ik (z1, o1) (z2, o2) = + (* (one_mask, Ints_t.of_int (Size.bit ik)) *) + if is_const (z2, o2) then shift_left_action ik (z1, o1) (Ints_t.to_int o2) + else + let max_bit = Z.log2up (Z.of_int (Size.bit ik)) in + let mask = !:(one_mask<<:max_bit) in + let concrete_values = concretize ((z2 &: mask), (o2 &: mask)) in + if (List.length concrete_values) == 0 then (one_mask, zero_mask) + else + let (v1, v2) = (ref zero_mask, ref zero_mask) in + List.iter (fun x -> let (a, b) = (shift_left_action ik (z1, o1) x) in + v1 := !v1 |: a; + v2 := !v2 |: b + ) concrete_values; + (!v1, !v2) end @@ -1250,25 +1293,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let show t = if t = bot () then "bot" else if t = top () then "top" else - let string_of_bitfield (z,o) = - let max_num_unknown_bits_to_concretize = Z.log2 @@ Z.of_int (Sys.word_size) |> fun x -> x lsr 2 in - let num_bits_unknown = - try - BArith.bits_unknown (z,o) |> fun i -> Z.popcount @@ Z.of_int @@ Ints_t.to_int i - with Z.Overflow -> max_num_unknown_bits_to_concretize + 1 - in - if num_bits_unknown > max_num_unknown_bits_to_concretize then - Format.sprintf "(%016X, %016X)" (Ints_t.to_int z) (Ints_t.to_int o) - else - (* TODO: Might be a source of long running tests.*) - BArith.concretize (z,o) |> List.map string_of_int |> String.concat "; " - |> fun s -> "{" ^ s ^ "}" - in let (z,o) = t in if BArith.is_const t then - Format.sprintf "%s | %s (unique: %d)" (string_of_bitfield (z,o)) (to_pretty_bits t) (Ints_t.to_int o) + Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) else - Format.sprintf "%s | %s" (string_of_bitfield (z,o)) (to_pretty_bits t) + Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 7f9be62dbe..2470ebf8ea 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -255,6 +255,7 @@ struct module I = IntDomain.SOverflowUnlifter (I) let ik = Cil.IInt + let ik_char = Cil.IChar let assert_equal x y = OUnit.assert_equal ~printer:I.show x y @@ -468,7 +469,7 @@ struct let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is - let assert_shift shift symb ik a b expected_values = + let assert_shift_xx shift symb ik a b expected_values = let bs1 = of_list ik (List.map of_int a) in let bs2 = of_list ik (List.map of_int b) in let bf_shift_res = (shift ik bs1 bs2) in @@ -476,19 +477,51 @@ struct let output_string elm = "Test shift (bf" ^ symb ^ string_of_int elm ^ ") failed: " ^ output_string in List.iter (fun v -> assert_bool (output_string v) (let test_result = I.equal_to (of_int v) bf_shift_res in test_result = `Top || test_result = `Eq)) expected_values + let assert_shift shift symb ik a b expected_values = + let bf1 = of_list ik (List.map of_int a) in + let bf2 = of_list ik (List.map of_int b) in + let bf_shift_resolution = (shift ik bf1 bf2) in + let x = of_list ik (List.map of_int expected_values) in + let output_string = I.show bf1 ^ symb ^ I.show bf2 ^ " was: " ^ I.show bf_shift_resolution ^ " but should be: " ^ I.show x in + let output = "Test shift ("^ I.show bf1 ^ symb ^ I.show bf2 ^ ") failed: " ^ output_string in + assert_bool (output) (I.equal bf_shift_resolution x) + let assert_shift_left ik a b res = assert_shift I.shift_left " << " ik a b res let assert_shift_right ik a b res = assert_shift I.shift_right " >> " ik a b res let test_shift_left _ = - assert_shift_left ik [2] [1] [4]; - assert_shift_left ik [-2] [1] [-4]; - assert_shift_left ik [2; 16] [1; 2] [4; 8; 32; 64] + assert_shift_left ik_char [-3] [7] [-128]; + assert_shift_left ik [-3] [7] [-384]; + assert_shift_left ik [2] [1; 2] [2; 4; 8; 16]; + assert_shift_left ik [1; 2] [1] [2; 4]; + assert_shift_left ik [-1; 1] [1] [-2; 2]; + assert_shift_left ik [-1] [4] [-16]; + assert_shift_left ik [-1] [1] [-2]; + assert_shift_left ik [-1] [2] [-4]; + assert_shift_left ik [-1] [3] [-8]; + assert_shift_left ik [-2] [1; 2] [-2; -4; -8; -16]; + assert_shift_left ik [-1] [1; 2] [-1; -2; -4; -8] + + + (* assert_shift_left ik [1] [64] [0]; + assert_shift_left ik [1] [64; 128] [0] *) let test_shift_right _ = assert_shift_right ik [4] [1] [2]; assert_shift_right ik [-4] [1] [-2]; - assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 8] + assert_shift_right ik [1] [1] [0]; + assert_shift_right ik [1] [1; 2] [0; 1]; + assert_shift_right ik [1; 2] [1; 2] [0; 1; 2; 3] + + + (* assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 8]; + assert_shift_right ik [8; 64] [1] [4; 32]; + assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 4; 8; 32]; + assert_shift_right ik [-2; 16] [1; 2] [-1; 0; 4; 8]; + assert_shift_right ik [2; -16] [1; 2] [-8; -4; 0; 1]; + assert_shift_right ik [-2; -16] [1; 2] [-8; -4; -1; 0]; + assert_shift_right ik [-53; 17; -24; 48] [3; 7] [-6; -3; 0; 2; 9] *) (* Arith *) @@ -736,6 +769,7 @@ struct "test_widen_1" >:: test_widen_1; "test_widen_2" >:: test_widen_2; + "test_of_interval" >:: test_of_interval; "test_of_bool" >:: test_of_bool; "test_to_bool" >:: test_to_bool; @@ -745,6 +779,7 @@ struct "test_logand" >:: test_logand; "test_logor" >:: test_logor; "test_lognot" >:: test_lognot; + "test_shift_left" >:: test_shift_left; "test_shift_right" >:: test_shift_right; From 3e4928ae5a87ae16c730014b69724d228b052e00 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 3 Dec 2024 09:56:14 +0100 Subject: [PATCH 071/111] removed commmented code and old wrong testcases --- src/cdomain/value/cdomains/intDomain.ml | 30 ------------------------- tests/unit/cdomains/intDomainTest.ml | 20 ----------------- 2 files changed, 50 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c82ab8f549..6ac8985615 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1179,36 +1179,6 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let get_o (_,o) = Ints_t.to_int o - (* let shift_right ik (z,o) c = - let sign_msk = make_msb_bitmask (Size.bit ik - c) in - if (isSigned ik) && (o <: Ints_t.zero) then - (z >>: c, (o >>: c) |: sign_msk) - else - ((z >>: c) |: sign_msk, o >>: c) - - let shift_right ik bf possible_shifts = - if is_const possible_shifts then shift_right ik bf (get_o possible_shifts) - else - let join_shrs c_lst = List.map (shift_right ik bf) c_lst |> List.fold_left join zero in - let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - if Z.to_int (min ik bf) >= max_bit then zero - else concretize (fst bf |: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) - |> join_shrs - - let shift_left _ (z,o) c = - let z_msk = make_lsb_bitmask c in - ((z <<: c) |: z_msk, o <<: c) - - let shift_left ik bf possible_shifts = - if is_const possible_shifts then shift_left ik bf (get_o possible_shifts) - else - let join_shls c_lst = List.map (shift_left ik bf) c_lst |> List.fold_left join zero in - let max_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - if Z.to_int (min ik bf) >= max_bit then zero - else concretize (fst bf |: make_msb_bitmask max_bit, snd bf &: make_lsb_bitmask max_bit) (* O( 2^(log(n)) ) *) - |> join_shls *) - - let shift_right_action ik (z,o) c = let sign_msk = make_msb_bitmask (Size.bit ik - c) in if (isSigned ik) && (o <: Ints_t.zero) then diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 2470ebf8ea..e8b9ae809f 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -469,14 +469,6 @@ struct let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is - let assert_shift_xx shift symb ik a b expected_values = - let bs1 = of_list ik (List.map of_int a) in - let bs2 = of_list ik (List.map of_int b) in - let bf_shift_res = (shift ik bs1 bs2) in - let output_string = I.show bs1 ^ symb ^ I.show bs2 in - let output_string elm = "Test shift (bf" ^ symb ^ string_of_int elm ^ ") failed: " ^ output_string in - List.iter (fun v -> assert_bool (output_string v) (let test_result = I.equal_to (of_int v) bf_shift_res in test_result = `Top || test_result = `Eq)) expected_values - let assert_shift shift symb ik a b expected_values = let bf1 = of_list ik (List.map of_int a) in let bf2 = of_list ik (List.map of_int b) in @@ -503,25 +495,13 @@ struct assert_shift_left ik [-1] [1; 2] [-1; -2; -4; -8] - (* assert_shift_left ik [1] [64] [0]; - assert_shift_left ik [1] [64; 128] [0] *) - let test_shift_right _ = assert_shift_right ik [4] [1] [2]; assert_shift_right ik [-4] [1] [-2]; assert_shift_right ik [1] [1] [0]; assert_shift_right ik [1] [1; 2] [0; 1]; assert_shift_right ik [1; 2] [1; 2] [0; 1; 2; 3] - - - (* assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 8]; - assert_shift_right ik [8; 64] [1] [4; 32]; - assert_shift_right ik [8; 64] [3; 5] [0; 1; 2; 4; 8; 32]; - assert_shift_right ik [-2; 16] [1; 2] [-1; 0; 4; 8]; - assert_shift_right ik [2; -16] [1; 2] [-8; -4; 0; 1]; - assert_shift_right ik [-2; -16] [1; 2] [-8; -4; -1; 0]; - assert_shift_right ik [-53; 17; -24; 48] [3; 7] [-6; -3; 0; 2; 9] *) (* Arith *) From 9bcd884ad3530558ae3a2f73cc23212d7b33a405 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 3 Dec 2024 15:32:09 +0100 Subject: [PATCH 072/111] fixed edge case where shift with 0 was done without zero in shifting bf --- src/cdomain/value/cdomains/intDomain.ml | 24 ++++++++++++++++-------- tests/unit/cdomains/intDomainTest.ml | 9 ++++++--- 2 files changed, 22 insertions(+), 11 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 6ac8985615..09d40084e4 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1187,12 +1187,16 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct ((z >>: c) |: sign_msk, o >>: c) let shift_right ik (z1, o1) (z2, o2) = - if is_const (z2, o2) then shift_right_action ik (z1, o1) (Ints_t.to_int o2) + if is_const (z2, o2) + then + shift_right_action ik (z1, o1) (Ints_t.to_int o2) else let max_bit = Z.log2up (Z.of_int (Size.bit ik)) in - let mask = !:(one_mask<<:max_bit) in - let concrete_values = concretize ((z2 &: mask), (o2 &: mask)) in - if (List.length concrete_values) == 0 then (one_mask, zero_mask) + let mask_usefull_bits = !:(one_mask<<:max_bit) in + let concrete_values = concretize ((z2 &: mask_usefull_bits), (o2 &: mask_usefull_bits)) in + if (((o2 &: mask_usefull_bits) == Ints_t.of_int 0) && (z2 != one_mask)) || (List.length concrete_values) == 0 + then + (one_mask, zero_mask) else let (v1, v2) = (ref zero_mask, ref zero_mask) in List.iter (fun x -> let (a, b) = (shift_right_action ik (z1, o1) x) in @@ -1207,12 +1211,16 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let shift_left ik (z1, o1) (z2, o2) = (* (one_mask, Ints_t.of_int (Size.bit ik)) *) - if is_const (z2, o2) then shift_left_action ik (z1, o1) (Ints_t.to_int o2) + if is_const (z2, o2) + then + shift_left_action ik (z1, o1) (Ints_t.to_int o2) else let max_bit = Z.log2up (Z.of_int (Size.bit ik)) in - let mask = !:(one_mask<<:max_bit) in - let concrete_values = concretize ((z2 &: mask), (o2 &: mask)) in - if (List.length concrete_values) == 0 then (one_mask, zero_mask) + let mask_usefull_bits = !:(one_mask <<: max_bit) in + let concrete_values = concretize ((z2 &: mask_usefull_bits), (o2 &: mask_usefull_bits)) in + if (((o2 &: mask_usefull_bits) == Ints_t.of_int 0) && (z2 != one_mask)) || (List.length concrete_values) == 0 + then + (one_mask, zero_mask) else let (v1, v2) = (ref zero_mask, ref zero_mask) in List.iter (fun x -> let (a, b) = (shift_left_action ik (z1, o1) x) in diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index e8b9ae809f..b3de4fe99f 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -492,15 +492,18 @@ struct assert_shift_left ik [-1] [2] [-4]; assert_shift_left ik [-1] [3] [-8]; assert_shift_left ik [-2] [1; 2] [-2; -4; -8; -16]; - assert_shift_left ik [-1] [1; 2] [-1; -2; -4; -8] - + assert_shift_left ik [-1] [1; 2] [-1; -2; -4; -8]; + assert_shift_left ik [1073741824] [128; 384] [0]; + assert_shift_left ik [1073741824] [0; 128; 384] [1073741824] let test_shift_right _ = assert_shift_right ik [4] [1] [2]; assert_shift_right ik [-4] [1] [-2]; assert_shift_right ik [1] [1] [0]; assert_shift_right ik [1] [1; 2] [0; 1]; - assert_shift_right ik [1; 2] [1; 2] [0; 1; 2; 3] + assert_shift_right ik [1; 2] [1; 2] [0; 1; 2; 3]; + assert_shift_right ik [32] [64; 2] [8; 32]; + assert_shift_right ik [32] [128; 384] [0] (* Arith *) From 6fe1162b96d9376181533f078f7769080470c812 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 3 Dec 2024 16:20:45 +0100 Subject: [PATCH 073/111] added of bitfield for refinements --- src/analyses/baseInvariant.ml | 20 ++++++++- src/cdomain/value/cdomains/intDomain.ml | 53 +++++++++++++++++++++++- src/cdomain/value/cdomains/intDomain.mli | 4 ++ 3 files changed, 73 insertions(+), 4 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 51a27e19f8..661fd481fa 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -395,10 +395,26 @@ struct | Le, Some false -> meet_bin (ID.starting ikind (Z.succ l2)) (ID.ending ikind (Z.pred u1)) | _, _ -> a, b) | _ -> a, b) - | BOr | BXor as op-> - if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; + | BOr as op-> + if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; (* Be careful: inv_exp performs a meet on both arguments of the BOr / BXor. *) a, b + | BXor as op -> + if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; + let a' = match ID.to_int b, ID.to_int c with + Some b, Some c -> (let res = IntDomain.Bitfield.to_int (IntDomain.Bitfield.logxor ikind (fst (IntDomain.Bitfield.of_int ikind b)) (fst (IntDomain.Bitfield.of_int ikind c))) in + match res with + Some r -> ID.meet a (ID.of_int ikind r) | + None -> a) | + _, _ -> a + in let b' = match ID.to_int a, ID.to_int c with + Some a, Some c -> (let res = IntDomain.Bitfield.to_int (IntDomain.Bitfield.logxor ikind (fst (IntDomain.Bitfield.of_int ikind a)) (fst (IntDomain.Bitfield.of_int ikind c))) in + match res with + Some r -> ID.meet b (ID.of_int ikind r) | + None -> b) | + _, _ -> b + (* Be careful: inv_exp performs a meet on both arguments of the BOr / BXor. *) + in a', b' | LAnd -> if ID.to_bool c = Some true then meet_bin c c diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5859b86f11..1983d601d8 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -233,6 +233,7 @@ sig val of_bool: bool -> t val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t val arbitrary: unit -> t QCheck.arbitrary val invariant: Cil.exp -> t -> Invariant.t end @@ -260,6 +261,7 @@ sig val of_bool: Cil.ikind -> bool -> t val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t val is_top_of: Cil.ikind -> t -> bool val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t @@ -310,6 +312,7 @@ sig val of_bool: Cil.ikind -> bool -> t val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t @@ -388,6 +391,8 @@ struct let to_incl_list x = I.to_incl_list x.v let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} + let of_bitfield ikind (z,o) = {v = I.of_bitfield ikind (z,o); ikind} + let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} let maximal x = I.maximal x.v @@ -522,6 +527,7 @@ module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct let to_incl_list x = None let of_interval ?(suppress_ovwarn=false) ik x = top_of ik let of_congruence ik x = top_of ik + let of_bitfield ik x = top_of ik let starting ?(suppress_ovwarn=false) ik x = top_of ik let ending ?(suppress_ovwarn=false) ik x = top_of ik let maximal x = None @@ -748,7 +754,25 @@ struct (* TODO: change to_int signature so it returns a big_int *) let to_int x = Option.bind x (IArith.to_int) + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) + let of_bitfield ik x = + let min ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = Ints_t.logand signBit o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) + else Ints_t.lognot z + in let max ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.logand signMask o + else o + in fst (norm ik (Some (min ik x, max ik x))) let of_int ik (x: int_t) = of_interval ik (x,x) let zero = Some IArith.zero let one = Some IArith.one @@ -1273,8 +1297,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let range ik bf = (BArith.min ik bf, BArith.max ik bf) - let minimal bf = Option.some (BArith.bits_known bf) (* TODO signedness info in type? No ik here! *) - let maximal bf = BArith.(bits_known bf |: bits_unknown bf) |> Option.some (* TODO signedness info in type? No ik here! *) + let maximal (z,o) = let isPositive = z < Ints_t.zero in + if o < Ints_t.zero && isPositive then (match Ints_t.upper_bound with Some maxVal -> Some (maxVal &: o) | None -> None ) + else Some o + + let minimal (z,o) = let isNegative = o < Ints_t.zero in + if z < Ints_t.zero && isNegative then (match Ints_t.lower_bound with Some minVal -> Some (minVal |: (!:z)) | None -> None ) + else Some (!:z) let norm ?(suppress_ovwarn=false) ik (z,o) = if BArith.is_invalid (z,o) then @@ -1331,6 +1360,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int done; norm ~suppress_ovwarn ik !bf + let of_congruence ik (c,m) = (if m = Ints_t.zero then fst (of_int ik c) else top_of ik) + let of_bool _ik = function true -> BArith.one | false -> BArith.zero let to_bool d = @@ -1564,6 +1595,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (i1,i2) |> fst ) pair_arb) let project ik p t = t + end @@ -1800,6 +1832,21 @@ struct let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) + let of_bitfield ik x = + let min ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = Ints_t.logand signBit o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) + else Ints_t.lognot z + in let max ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.logand signMask o + else o + in fst (norm_interval ik (min ik x, max ik x)) + let of_int ik (x: int_t) = of_interval ik (x, x) let lt ik x y = @@ -2241,6 +2288,7 @@ struct let to_incl_list x = None let of_interval ?(suppress_ovwarn=false) ik x = top_of ik let of_congruence ik x = top_of ik + let of_bitfield ik x = top_of ik let starting ?(suppress_ovwarn=false) ikind x = top_of ikind let ending ?(suppress_ovwarn=false) ikind x = top_of ikind let maximal x = None @@ -3912,6 +3960,7 @@ module IntDomTupleImpl = struct let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } + let of_bitfield ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_bitfield ik } let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= let opt f a = diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index d6bb233aee..401ba84e94 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -228,6 +228,7 @@ sig val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t val arbitrary: unit -> t QCheck.arbitrary val invariant: Cil.exp -> t -> Invariant.t end @@ -262,6 +263,7 @@ sig val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t val is_top_of: Cil.ikind -> t -> bool val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t @@ -325,6 +327,8 @@ sig val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t From bad0bb8e2d6e26f8166ade7ffcc70cd9a1f5c3f7 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 3 Dec 2024 16:33:08 +0100 Subject: [PATCH 074/111] remove duplicate function --- src/cdomain/value/cdomains/intDomain.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 9c8e800ad5..a4d1347947 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1500,7 +1500,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = z1 /: z2 in (!:tmp, tmp)) else top_of ik in norm ik res - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) let rem ik x y = if BArith.is_const x && BArith.is_const y then ( @@ -1556,7 +1556,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) in match bf, cong with | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> let congruenceMask = !:m in From abde7e41b0174dd8ef12ca9ea2b4642c9a4710fd Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 3 Dec 2024 17:51:39 +0100 Subject: [PATCH 075/111] Revert "remove duplicate function" This reverts commit bad0bb8e2d6e26f8166ade7ffcc70cd9a1f5c3f7. --- src/cdomain/value/cdomains/intDomain.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a4d1347947..9c8e800ad5 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1500,7 +1500,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = z1 /: z2 in (!:tmp, tmp)) else top_of ik in norm ik res - let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) + let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) let rem ik x y = if BArith.is_const x && BArith.is_const y then ( @@ -1556,6 +1556,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) in match bf, cong with | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> let congruenceMask = !:m in From 937b341030022300182f6bfbf740381970515f20 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 3 Dec 2024 18:05:24 +0100 Subject: [PATCH 076/111] Reapply "remove duplicate function" This reverts commit abde7e41b0174dd8ef12ca9ea2b4642c9a4710fd. --- src/cdomain/value/cdomains/intDomain.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 9c8e800ad5..a4d1347947 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1500,7 +1500,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = z1 /: z2 in (!:tmp, tmp)) else top_of ik in norm ik res - let is_power_of_two x = Ints_t.(logand x (sub x one) = zero) + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) let rem ik x y = if BArith.is_const x && BArith.is_const y then ( @@ -1556,7 +1556,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) in match bf, cong with | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> let congruenceMask = !:m in From ddfaace5ef1b00a3c53389f02a816a30cd29ae00 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 3 Dec 2024 18:15:51 +0100 Subject: [PATCH 077/111] fix bug --- src/cdomain/value/cdomains/intDomain.ml | 26 ++++++++++--------- .../82-bitfield/08-refine-with-bifield.c | 13 ++++++++++ 2 files changed, 27 insertions(+), 12 deletions(-) create mode 100644 tests/regression/82-bitfield/08-refine-with-bifield.c diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a4d1347947..edaa91f8cd 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1121,7 +1121,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let top_bool = join one zero let bits_known (z,o) = z ^: o - let bits_unknown (z,o) = z &: o + let bits_unknown (z,o) = !:(bits_known (z,o)) let bits_set bf = (snd bf) &: (bits_known bf) let bits_invalid (z,o) = !:(z |: o) @@ -1262,7 +1262,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let next_bit_string = if current_bit_impossible = Ints_t.one then "⊥" - else if current_bit_known = Ints_t.one || current_bit_known = Ints_t.zero + else if current_bit_known = Ints_t.one then string_of_int (Ints_t.to_int bit_value) else "⊤" in to_pretty_bits' (known_mask >>: 1) (impossible_mask >>: 1) (o_mask >>: 1) (max_bits - 1) (next_bit_string ^ acc) in @@ -1277,8 +1277,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let range ik bf = (BArith.min ik bf, BArith.max ik bf) - let minimal bf = Option.some (BArith.bits_known bf) (* TODO signedness info in type? No ik here! *) - let maximal bf = BArith.(bits_known bf |: bits_unknown bf) |> Option.some (* TODO signedness info in type? No ik here! *) + + let maximal (z,o) = let isPositive = z < Ints_t.zero in + if o < Ints_t.zero && isPositive then (match Ints_t.upper_bound with Some maxVal -> Some (maxVal &: o) | None -> None ) + else Some o + + let minimal (z,o) = let isNegative = o < Ints_t.zero in + if z < Ints_t.zero && isNegative then (match Ints_t.lower_bound with Some minVal -> Some (minVal |: (!:z)) | None -> None ) + else Some (!:z) let norm ?(suppress_ovwarn=false) ik (z,o) = if BArith.is_invalid (z,o) then @@ -1504,18 +1510,14 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rem ik x y = if BArith.is_const x && BArith.is_const y then ( - (* x % y = x - (x / y) * y *) - let tmp = fst (div ik x y) in - let tmp = fst (mul ik tmp y) in - fst (sub ik x tmp)) + let def_x = Option.get (to_int x) in + let def_y = Option.get (to_int y) in + fst (of_int ik (Ints_t.rem def_x def_y)) + ) else if BArith.is_const y && is_power_of_two (snd y) then ( let mask = Ints_t.sub (snd y) Ints_t.one in - print_endline (Ints_t.to_string mask); - print_endline (Ints_t.to_string (Ints_t.lognot mask)); let newz = Ints_t.logor (fst x) (Ints_t.lognot mask) in let newo = Ints_t.logand (snd x) mask in - print_endline (Ints_t.to_string newz); - print_endline (Ints_t.to_string newo); norm ik (newz, newo) |> fst ) else top_of ik diff --git a/tests/regression/82-bitfield/08-refine-with-bifield.c b/tests/regression/82-bitfield/08-refine-with-bifield.c new file mode 100644 index 0000000000..f6a4f14c69 --- /dev/null +++ b/tests/regression/82-bitfield/08-refine-with-bifield.c @@ -0,0 +1,13 @@ +// PARAM: --enable ana.int.interav --set ana.int.refinement fixpoint +#include +#include +#include + +int main() { + int a = rand(); + + if (a % 8 == 3) { + int b = a & 0x7; + assert(b == 3); // SUCCESS + } +} From 24f305f343dfdbc9cd23acb0788d32287c6091a3 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 4 Dec 2024 02:45:15 +0100 Subject: [PATCH 078/111] add some more tests --- src/cdomain/value/cdomains/intDomain.ml | 2 +- .../82-bitfield/08-refine-with-bifield.c | 13 --- .../82-bitfield/08-refine-with-bitfield.c | 99 +++++++++++++++++++ .../82-bitfield/09-refine-interval.c | 22 +++++ 4 files changed, 122 insertions(+), 14 deletions(-) delete mode 100644 tests/regression/82-bitfield/08-refine-with-bifield.c create mode 100644 tests/regression/82-bitfield/08-refine-with-bitfield.c create mode 100644 tests/regression/82-bitfield/09-refine-interval.c diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index edaa91f8cd..2e081aff5f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1121,7 +1121,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let top_bool = join one zero let bits_known (z,o) = z ^: o - let bits_unknown (z,o) = !:(bits_known (z,o)) + let bits_unknown (z,o) = z &: o let bits_set bf = (snd bf) &: (bits_known bf) let bits_invalid (z,o) = !:(z |: o) diff --git a/tests/regression/82-bitfield/08-refine-with-bifield.c b/tests/regression/82-bitfield/08-refine-with-bifield.c deleted file mode 100644 index f6a4f14c69..0000000000 --- a/tests/regression/82-bitfield/08-refine-with-bifield.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --enable ana.int.interav --set ana.int.refinement fixpoint -#include -#include -#include - -int main() { - int a = rand(); - - if (a % 8 == 3) { - int b = a & 0x7; - assert(b == 3); // SUCCESS - } -} diff --git a/tests/regression/82-bitfield/08-refine-with-bitfield.c b/tests/regression/82-bitfield/08-refine-with-bitfield.c new file mode 100644 index 0000000000..64cb588f2d --- /dev/null +++ b/tests/regression/82-bitfield/08-refine-with-bitfield.c @@ -0,0 +1,99 @@ +// PARAM: --enable ana.int.bitfield --set ana.int.refinement fixpoint +#include +#include +#include + +int main() { + int a = rand(); + + // Basic bitwise properties + __goblint_assert((a & 0) == 0); // Any number ANDed with 0 is 0 + __goblint_assert((a | 0xFFFFFFFF) == 0xFFFFFFFF); // Any number ORed with all 1s gives all 1s + + // Testing alignment and divisibility with powers of 2 + int ALIGN_8 = 0x7; // 111 in binary + if ((a & ALIGN_8) == 0) { + __goblint_assert(a % 8 == 0); // Number is aligned to 8 + } + + int ALIGN_32 = 0x1F; // 11111 in binary + if ((a & ALIGN_32) == 0) { + __goblint_assert(a % 32 == 0); // Number is divisible by 32 + } + + // Testing specific power of 2 patterns + int POW2_MASK = (1 << 4) - 1; // 15 (0b1111) + if ((a & POW2_MASK) == 8) { + __goblint_assert((a & 0xf) == 8); // Exactly bit 3 set in lower 4 bits + __goblint_assert((a & 12) == 8); // Bits 2-3 must be 1000 + __goblint_assert((a & 3) == 0); // Bits 0-1 must be 0 + } + + // Testing specific bit patterns and masking + if ((a & 0x3) == 0x3) { + __goblint_assert(a % 4 >= 3); // Last two bits are 1 + __goblint_assert((a & 1) == 1); // Least significant bit must be 1 + } + + if ((a & 0xC) == 0x8) { // 1000 in binary + __goblint_assert((a & 0x4) == 0); // Bit 2 must be 0 + __goblint_assert((a & 0x8) == 0x8); // Bit 3 must be 1 + } + + // Testing OR operations with patterns + int OR_MASK = 0x55; // 01010101 in binary + if ((a | OR_MASK) == 0x55) { + __goblint_assert(a == 0); // Only possible if a is 0 + __goblint_assert((a | 0xFF) == 0xFF); // ORing with all 1s gives all 1s + } + + if ((a | 0x6) == a) { + __goblint_assert((a & 0x6) == 0x6); // Bits 1 and 2 must be set + } + + // Testing XOR operations + int XOR_MASK = 0xAA; // 10101010 in binary + if ((a ^ XOR_MASK) == 0) { + __goblint_assert(a == 0xAA); // Must match the mask exactly + __goblint_assert((a & 0xAA) == 0xAA); // All alternating bits must be 1 + } + + if ((a ^ 0xFF) == 0) { + __goblint_assert(a == 0xFF); // Only possible if a is 0xFF + } + + // Testing complex bit patterns + int COMPLEX_MASK = 0x33; // 00110011 in binary + if ((a & COMPLEX_MASK) == 0x11) { + __goblint_assert((a & 0x22) == 0); // Middle bits must be 0 + __goblint_assert((a & 0x11) == 0x11); // Outer bits must be 1 + } + + // Testing shifted masks and patterns + int SHIFT_MASK = 3 << 2; // 1100 in binary + if ((a & SHIFT_MASK) == SHIFT_MASK) { + __goblint_assert((a & 12) == 12); // Both bits must be set + __goblint_assert(((a >> 2) & 3) == 3); // When shifted right, lowest bits must be 11 + __goblint_assert(((a << 2) & 12) == 12); // When shifted left, highest bits must be 1100 + } + + int SHIFTED = 0x7 << 3; // 111000 in binary + if ((a & SHIFTED) == 0) { + __goblint_assert((a & 0x38) == 0); // Bits 3,4,5 must be 0 + } + + // Testing sign bits and negative numbers + if ((a & 0x80) == 0x80) { + __goblint_assert(a & 0x80); // Highest bit must be set + __goblint_assert((a | 0x7F) >= 0x80); // Result must be >= 128 + } + + // Testing bitwise complement + int COMP_MASK = ~0xF0; // Complement of 11110000 + if ((a & COMP_MASK) == 0x0F) { + __goblint_assert((a & 0xF0) == 0); // Upper 4 bits must be 0 + __goblint_assert((a & 0x0F) == 0x0F); // Lower 4 bits must be all 1s + } + + return 0; +} \ No newline at end of file diff --git a/tests/regression/82-bitfield/09-refine-interval.c b/tests/regression/82-bitfield/09-refine-interval.c new file mode 100644 index 0000000000..69c24ea0e3 --- /dev/null +++ b/tests/regression/82-bitfield/09-refine-interval.c @@ -0,0 +1,22 @@ +// PARAM: --enable ana.int.bitfield --set ana.int.refinement fixpoint +#include +#include +#include + +int main() { + int a = rand(); + + // 1110 in binary + int inv_mask = ~0xe; // 1111...10001 in binary + + if ((a & inv_mask) == 0) { + __goblint_check(a <= 14); // SUCCESS + __goblint_check(a >= 1); // SUCCESS + + if (1 <= a && a <= 14) { + printf("a is in the interval [1, 14]\n"); + } else { + __goblint_check(0); // NOWARN (unreachable) + } + } +} \ No newline at end of file From 7c4411d967725f66dae6b91e563ef5bd057cfebe Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 4 Dec 2024 22:31:36 +0100 Subject: [PATCH 079/111] add missing regression tests --- tests/regression/01-cpa/76-bitfield.c | 36 -------- tests/regression/82-bitfield/00-simple-demo.c | 29 +++++++ .../regression/82-bitfield/01-simple-arith.c | 13 +++ .../regression/82-bitfield/02-complex-arith.c | 62 ++++++++++++++ .../82-bitfield/03-simple-bitwise-c | 14 ++++ .../82-bitfield/04-complex-bitwise.c | 83 +++++++++++++++++++ tests/regression/82-bitfield/04-refines.c | 15 ---- 7 files changed, 201 insertions(+), 51 deletions(-) delete mode 100644 tests/regression/01-cpa/76-bitfield.c create mode 100644 tests/regression/82-bitfield/00-simple-demo.c create mode 100644 tests/regression/82-bitfield/01-simple-arith.c create mode 100644 tests/regression/82-bitfield/02-complex-arith.c create mode 100644 tests/regression/82-bitfield/03-simple-bitwise-c create mode 100644 tests/regression/82-bitfield/04-complex-bitwise.c delete mode 100644 tests/regression/82-bitfield/04-refines.c diff --git a/tests/regression/01-cpa/76-bitfield.c b/tests/regression/01-cpa/76-bitfield.c deleted file mode 100644 index 2125895d18..0000000000 --- a/tests/regression/01-cpa/76-bitfield.c +++ /dev/null @@ -1,36 +0,0 @@ -//PARAM: --enable ana.int.bitfield -#include -#include -#include - -#define ANY_ERROR 5 // 5 -int main() { - int testvar = 235; - - int state; - int r = rand() % 3; // {r 7→ [0; 2],state 7→ [MIN INT; MAX INT]} - switch (r) { - case 0: - state = 0; /* 0 */ - testvar = 1; - break; - case 1: - state = 8; /* 8 */ - testvar = 1; - break; - default: - state = 10; /* 10 */ - testvar = 1; - break; - } - - if(state & ANY_ERROR == 0) { - printf("Error\n"); - } else { - printf("No error\n"); - } - - // {r 7→ [0; 2],state 7→ [0; 10]} - assert((state & ANY_ERROR) == 0); - __goblint_check((state & ANY_ERROR) == 0); -} diff --git a/tests/regression/82-bitfield/00-simple-demo.c b/tests/regression/82-bitfield/00-simple-demo.c new file mode 100644 index 0000000000..e87fa63d79 --- /dev/null +++ b/tests/regression/82-bitfield/00-simple-demo.c @@ -0,0 +1,29 @@ +// PARAM: --enable ana.int.bitfield +#include +#include +#include + +#define ANY_ERROR 5 // 0b0101 + +int main() { + int testvar = 235; + + int state; + int r = rand() % 3; + switch (r) { + case 0: + state = 0; /* 0b000 */ + testvar = 1; + break; + case 1: + state = 8; /* 0b1000 */ + testvar = 1; + break; + default: + state = 10; /* 0b1010 */ + testvar = 1; + break; + } + + __goblint_check((state & ANY_ERROR) == 0); +} \ No newline at end of file diff --git a/tests/regression/82-bitfield/01-simple-arith.c b/tests/regression/82-bitfield/01-simple-arith.c new file mode 100644 index 0000000000..045c26e5d4 --- /dev/null +++ b/tests/regression/82-bitfield/01-simple-arith.c @@ -0,0 +1,13 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a = 19; + int b = 23; + + __goblint_check(a + b == 42); + __goblint_check(a - b == -4); + __goblint_check(a * b == 437); + __goblint_check(a / b == 0); + __goblint_check(a % b == 19); +} \ No newline at end of file diff --git a/tests/regression/82-bitfield/02-complex-arith.c b/tests/regression/82-bitfield/02-complex-arith.c new file mode 100644 index 0000000000..ff0db443ee --- /dev/null +++ b/tests/regression/82-bitfield/02-complex-arith.c @@ -0,0 +1,62 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a; + int b = 23; + + int r = rand() % 2; + switch (r) { + case 0: + a = 19; + printf("a = 19\n"); + break; + default: + a = 17; + printf("a = 17\n"); + break; + } + + // PLUS + + int c_add = a + b; + + if (c_add == 40) { + goblint_check(1); // reachable + } + if (c_add == 42) { + goblint_check(1); // reachable + } + if (c_add > 42 || c_add < 40) { + __goblint_check(0); // NOWARN (unreachable) + } + + // MINUS + + int c_minus = b - a; + + if (c_minus == 6) { + goblint_check(1); // reachable + } + if (c_minus == 4) { + goblint_check(1); // reachable + } + if (c_minus > 6 || c_minus < 4) { + __goblint_check(0); // NOWARN (unreachable) + } + + // MULT + + int c_mult = a * b; + + if (c_mult == 391) { + goblint_check(1); // reachable + } + if (c_mult == 437) { + goblint_check(1); // reachable + } + + // DIV + + // Div on non-unique bitfields is not supported +} \ No newline at end of file diff --git a/tests/regression/82-bitfield/03-simple-bitwise-c b/tests/regression/82-bitfield/03-simple-bitwise-c new file mode 100644 index 0000000000..2e0ce3a57d --- /dev/null +++ b/tests/regression/82-bitfield/03-simple-bitwise-c @@ -0,0 +1,14 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a = 19; + int b = 14; + + __goblint_check((a & b) == 2); + __goblint_check((a | b) == 31); + __goblint_check((a ^ b) == 29); + __goblint_check((~a) == -20); + __goblint_check((a << 2) == 76); + __goblint_check((a >> 2) == 4); +} \ No newline at end of file diff --git a/tests/regression/82-bitfield/04-complex-bitwise.c b/tests/regression/82-bitfield/04-complex-bitwise.c new file mode 100644 index 0000000000..ec2d73625e --- /dev/null +++ b/tests/regression/82-bitfield/04-complex-bitwise.c @@ -0,0 +1,83 @@ +// PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield +#include + +int main() { + int a; + int b = 21; // 10101 in binary + + int r = rand() % 2; + switch (r) { + case 0: + a = 19; // 10011 in binary + printf("a = 19\n"); + break; + default: + a = 17; // 10001 in binary + printf("a = 17\n"); + break; + } + + // AND + int c_and = a & b; + + if (c_and == 17) { + __goblint_check(1); // reachable (19 & 21 = 17, 17 & 21 = 17) + } + if (c_and != 17) { + __goblint_check(0); // NOWARN (unreachable) + } + + // OR + int c_or = a | b; + + if (c_or == 23) { + __goblint_check(1); // reachable (19|21 = 23) + } + if (c_or == 21) { + __goblint_check(1); // reachable (17|21 = 21) + } + if (c_or > 23 || c_or < 21) { + __goblint_check(0); // NOWARN (unreachable) + } + + // XOR + int c_xor = a ^ b; + + if (c_xor == 6) { + __goblint_check(1); // reachable (19^21 = 6) + } + if (c_xor == 4) { + __goblint_check(1); // reachable (17^21 = 4) + } + if (c_xor > 6 || c_xor < 4) { + __goblint_check(0); // NOWARN (unreachable) + } + + // Left shift + int c_lshift = a << 1; + + if (c_lshift == 38) { + __goblint_check(1); // reachable (19<<1 = 38) + } + if (c_lshift == 34) { + __goblint_check(1); // reachable (17<<1 = 34) + } + if (c_lshift > 38 || c_lshift < 34) { + __goblint_check(0); // NOWARN (unreachable) + } + + // Right shift + int c_rshift = a >> 1; + + if (c_rshift == 9) { + __goblint_check(1); // reachable (19>>1 = 9) + } + if (c_rshift == 8) { + __goblint_check(1); // reachable (17>>1 = 8) + } + if (c_rshift > 9 || c_rshift < 8) { + __goblint_check(0); // NOWARN (unreachable) + } + + return 0; +} \ No newline at end of file diff --git a/tests/regression/82-bitfield/04-refines.c b/tests/regression/82-bitfield/04-refines.c deleted file mode 100644 index 21f41635b8..0000000000 --- a/tests/regression/82-bitfield/04-refines.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --enable ana.int.congruence --set ana.int.refinement fixpoint -#include -#include -#include - - -int main() { - int state= rand(); - - __goblint_assume(state % 8 == 3); - - int a = state & 0x7f; - - __goblint_check((a== 3)); -} From 6c2c5708a9059790bcffa31e57dfcce2d6edeae7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Sat, 7 Dec 2024 17:02:36 +0100 Subject: [PATCH 080/111] simple refinements for base invariant with bitfields --- src/analyses/baseInvariant.ml | 32 ++-- src/cdomain/value/cdomains/intDomain.ml | 166 +++++++++++------- src/cdomain/value/cdomains/intDomain.mli | 1 + .../82-bitfield/10-refine-interval.c | 19 ++ 4 files changed, 133 insertions(+), 85 deletions(-) create mode 100644 tests/regression/82-bitfield/10-refine-interval.c diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 661fd481fa..950fd6f236 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -395,26 +395,18 @@ struct | Le, Some false -> meet_bin (ID.starting ikind (Z.succ l2)) (ID.ending ikind (Z.pred u1)) | _, _ -> a, b) | _ -> a, b) - | BOr as op-> - if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; + | BOr -> (* Be careful: inv_exp performs a meet on both arguments of the BOr / BXor. *) - a, b - | BXor as op -> - if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; - let a' = match ID.to_int b, ID.to_int c with - Some b, Some c -> (let res = IntDomain.Bitfield.to_int (IntDomain.Bitfield.logxor ikind (fst (IntDomain.Bitfield.of_int ikind b)) (fst (IntDomain.Bitfield.of_int ikind c))) in - match res with - Some r -> ID.meet a (ID.of_int ikind r) | - None -> a) | - _, _ -> a - in let b' = match ID.to_int a, ID.to_int c with - Some a, Some c -> (let res = IntDomain.Bitfield.to_int (IntDomain.Bitfield.logxor ikind (fst (IntDomain.Bitfield.of_int ikind a)) (fst (IntDomain.Bitfield.of_int ikind c))) in - match res with - Some r -> ID.meet b (ID.of_int ikind r) | - None -> b) | - _, _ -> b + if PrecisionUtil.get_bitfield () then + ID.meet a (ID.logand a c), ID.meet b (ID.logand b c) + else a, b + | BXor -> (* Be careful: inv_exp performs a meet on both arguments of the BOr / BXor. *) - in a', b' + if PrecisionUtil.get_bitfield () then + let a' = ID.meet a (ID.logxor c b) + in let b' = ID.meet b (ID.logxor a c) + in a', b' + else a,b | LAnd -> if ID.to_bool c = Some true then meet_bin c c @@ -431,7 +423,9 @@ struct | None -> if M.tracing then M.tracel "inv" "Unhandled case for operator x %a 1 = %a" d_binop op ID.pretty c; a) | _ -> if M.tracing then M.tracel "inv" "Unhandled case for operator x %a %a = %a" d_binop op ID.pretty b ID.pretty c; a in - a, b + if PrecisionUtil.get_bitfield () then + ID.meet a (ID.logor a c), ID.meet b (ID.logor b c) + else a, b | op -> if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; a, b diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 1983d601d8..2a9ae32562 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -267,6 +267,7 @@ sig val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_bitfield: Cil.ikind -> t -> (int_t * int_t) -> t val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t @@ -1077,6 +1078,10 @@ struct let refine_with_interval ik a b = meet ik a b + let refine_with_bitfield ik a b = + let interv = of_bitfield ik b in + meet ik a interv + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = match intv, excl with | None, _ | _, None -> intv @@ -1150,7 +1155,9 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bits_invalid (z,o) = !:(z |: o) let is_const (z,o) = (z ^: o) =: one_mask - let is_invalid (z,o) = not ((!:(z |: o)) =: Ints_t.zero) + let is_invalid ik (z,o) = + let mask = !:(Ints_t.of_bigint (snd (Size.range ik))) in + not ((!:(z |: o |: mask)) = Ints_t.zero) let nabla x y= if x =: (x |: y) then x else one_mask @@ -1265,38 +1272,22 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let next_bit_string = if current_bit_impossible = Ints_t.one then "⊥" - else if current_bit_known = Ints_t.one || current_bit_known = Ints_t.zero + else if current_bit_known = Ints_t.one then string_of_int (Ints_t.to_int bit_value) else "⊤" in to_pretty_bits' (known_mask >>: 1) (impossible_mask >>: 1) (o_mask >>: 1) (max_bits - 1) (next_bit_string ^ acc) in - to_pretty_bits' known_bits invalid_bits o num_bits_to_print "" - - let show t = - if t = bot () then "bot" else - if t = top () then "top" else - let string_of_bitfield (z,o) = - let max_num_unknown_bits_to_concretize = Z.log2 @@ Z.of_int (Sys.word_size) |> fun x -> x lsr 2 in - let num_bits_unknown = - try - BArith.bits_unknown (z,o) |> fun i -> Z.popcount @@ Z.of_int @@ Ints_t.to_int i - with Z.Overflow -> max_num_unknown_bits_to_concretize + 1 - in - if num_bits_unknown > max_num_unknown_bits_to_concretize then - Format.sprintf "(%016X, %016X)" (Ints_t.to_int z) (Ints_t.to_int o) - else - (* TODO: Might be a source of long running tests.*) - BArith.concretize (z,o) |> List.map string_of_int |> String.concat "; " - |> fun s -> "{" ^ s ^ "}" - in - let (z,o) = t in - if BArith.is_const t then - Format.sprintf "%s | %s (unique: %d)" (string_of_bitfield (z,o)) (to_pretty_bits t) (Ints_t.to_int o) - else - Format.sprintf "%s | %s" (string_of_bitfield (z,o)) (to_pretty_bits t) + "0b" ^ to_pretty_bits' known_bits invalid_bits o num_bits_to_print "" + + let show t = + if t = bot () then "bot" else + if t = top () then "top" else + let (z,o) = t in + Format.sprintf "{zs:%d, os:%d} %s" (Ints_t.to_int z) (Ints_t.to_int o) (to_pretty_bits t) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let range ik bf = (BArith.min ik bf, BArith.max ik bf) + let maximal (z,o) = let isPositive = z < Ints_t.zero in if o < Ints_t.zero && isPositive then (match Ints_t.upper_bound with Some maxVal -> Some (maxVal &: o) | None -> None ) else Some o @@ -1305,10 +1296,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if z < Ints_t.zero && isNegative then (match Ints_t.lower_bound with Some minVal -> Some (minVal |: (!:z)) | None -> None ) else Some (!:z) - let norm ?(suppress_ovwarn=false) ik (z,o) = - if BArith.is_invalid (z,o) then + let norm ?(debug=false) ?(suppress_ovwarn=false) ik (z,o) = + if BArith.is_invalid ik (z,o) then (bot (), {underflow=false; overflow=false}) - else + else let (min_ik, max_ik) = Size.range ik in let wrap ik (z,o) = if isSigned ik then @@ -1352,13 +1343,41 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let of_interval ?(suppress_ovwarn=false) ik (x,y) = let (min_ik, max_ik) = Size.range ik in - let current = ref (Z.max (Ints_t.to_bigint x) min_ik) in - let bf = ref (bot ()) in - while Z.leq !current (Z.min (Ints_t.to_bigint y) max_ik) do - bf := BArith.join !bf (BArith.of_int @@ Ints_t.of_bigint !current); - current := Z.add !current Z.one - done; - norm ~suppress_ovwarn ik !bf + let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in + let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in + + let rec analyze_bits pos (acc_z, acc_o) = + if pos < 0 then (acc_z, acc_o) + else + let position = Ints_t.shift_left Ints_t.one pos in + let mask = Ints_t.sub position Ints_t.one in + let remainder = Ints_t.logand startv mask in + + let without_remainder = Ints_t.sub startv remainder in + let bigger_number = Ints_t.add without_remainder position in + + let bit_status = + if Ints_t.compare bigger_number endv <= 0 then + `top + else + if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then + `one + else + `zero + in + + let new_acc = + match bit_status with + | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) + | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) + | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) + + in + analyze_bits (pos - 1) new_acc + in + let result = analyze_bits (Size.bit ik - 1) (bot()) in + let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) + in norm ~debug:true ~suppress_ovwarn ik casted let of_congruence ik (c,m) = (if m = Ints_t.zero then fst (of_int ik c) else top_of ik) @@ -1403,12 +1422,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid ik b || BArith.is_invalid ik a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_right ik a b) let shift_left ik a b = M.trace "bitfield" "shift_left"; - if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid ik b || BArith.is_invalid ik a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_left ik a b) (* Arith *) @@ -1438,7 +1457,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let (rv, rm) = add_paper pv pm qv qm in let o3 = rv |: rm in let z3 = !:rv |: rm in - norm ik (z3, o3) + (* let _ = print_endline (show (z3, o3)) in + let _ = (match maximal (z3,o3) with Some k -> print_endline (Ints_t.to_string k) | None -> print_endline "None") in + let _ = (match minimal (z3,o3) with Some k -> print_endline (Ints_t.to_string k) | None -> print_endline "None") in + let _ = (match Size.range ik with (a,b) -> print_endline ("(" ^ Z.to_string a ^ "; " ^ Z.to_string b ^ ")")) in *) + norm ik (z3,o3) let sub ?no_ov ik (z1, o1) (z2, o2) = let pv = o1 &: !:z1 in @@ -1499,12 +1522,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rem ik x y = M.trace "bitfield" "rem"; - if BArith.is_const x && BArith.is_const y then ( - (* x % y = x - (x / y) * y *) - let tmp = fst (div ik x y) in - let tmp = fst (mul ik tmp y) in - fst (sub ik x tmp)) - else top_of ik + match to_int x, to_int y with + Some a, Some b -> fst (of_int ik (Ints_t.rem a b)) | + _, _ -> top_of ik let eq ik x y = if (BArith.max ik x) <= (BArith.min ik y) && (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true @@ -1534,37 +1554,30 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int IntInvariant.of_interval e ik range let starting ?(suppress_ovwarn=false) ik n = - if Ints_t.compare n Ints_t.zero >= 0 then - (* sign bit can only be 0, as all numbers will be positive *) - let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in - let zs = BArith.one_mask in - let os = !:signBitMask &: BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) + let (min_ik, max_ik) = Size.range ik in + of_interval ~suppress_ovwarn ik (n, Ints_t.of_bigint max_ik) let ending ?(suppress_ovwarn=false) ik n = - if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then - (* sign bit can only be 1, as all numbers will be negative *) - let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in - let zs = !:signBitMask &: BArith.one_mask in - let os = BArith.one_mask in - (norm ~suppress_ovwarn ik @@ (zs,os)) - else - (norm ~suppress_ovwarn ik @@ (top ())) + let (min_ik, max_ik) = Size.range ik in + of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = - let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) in match bf, cong with - | (z,o), Some (c, m) when is_power_of_two m -> + | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> let congruenceMask = !:m in let newz = (!:congruenceMask &: z) |: (congruenceMask &: !:c) in let newo = (!:congruenceMask &: o) |: (congruenceMask &: c) in norm ik (newz, newo) |> fst | _ -> norm ik bf |> fst - let refine_with_interval ik t i = norm ik t |> fst + let refine_with_interval ik t itv = + match itv with + | None -> norm ik t |> fst + | Some (l, u) -> meet ik t (of_interval ik (l, u) |> fst) + + let refine_with_bitfield ik x y = meet ik x y let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst @@ -2112,6 +2125,10 @@ struct let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] + let refine_with_bitfield ik x y = + let interv = of_bitfield ik y in + meet ik x interv + let refine_with_incl_list ik intvs = function | None -> intvs | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) @@ -2937,6 +2954,7 @@ struct let refine_with_interval ik a b = match a, b with | x, Some(i) -> meet ik x (of_interval ik i) | _ -> a + let refine_with_bitfield ik x y = x let refine_with_excl_list ik a b = match a, b with | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) | _ -> a @@ -3299,6 +3317,8 @@ module Enums : S with type int_t = Z.t = struct let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) + let refine_with_bitfield ik x y = x + let refine_with_excl_list ik a b = match b with | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) @@ -3798,6 +3818,8 @@ struct if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; refn + let refine_with_bitfield ik a b = a + let refine_with_congruence ik a b = meet ik a b let refine_with_excl_list ik a b = a let refine_with_incl_list ik a b = a @@ -3985,6 +4007,17 @@ module IntDomTupleImpl = struct , opt I5.refine_with_interval ik e intv , opt I6.refine_with_interval ik f intv ) + let refine_with_bitfield ik (a, b, c, d, e,f) bf = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_bitfield ik a bf + , opt I2.refine_with_bitfield ik b bf + , opt I3.refine_with_bitfield ik c bf + , opt I4.refine_with_bitfield ik d bf + , opt I5.refine_with_bitfield ik e bf + , opt I6.refine_with_bitfield ik f bf ) + let refine_with_excl_list ik (a, b, c, d, e,f) excl = let opt f a = curry @@ function Some x, y -> Some (f a x y) | _ -> None @@ -4096,8 +4129,9 @@ module IntDomTupleImpl = struct in [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e,f) b); (* TODO: get interval across all domains with minimal and maximal *) - (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e,f) d)] + (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e, f) b); (* TODO: get interval across all domains with minimal and maximal *) + (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e, f) d); + (fun (a, b, c, d, e, f) -> maybe refine_with_bitfield ik (a, b, c, d, e, f) f)] let refine ik ((a, b, c, d, e,f) : t ) : t = let dt = ref (a, b, c, d, e,f) in diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 401ba84e94..55149cdb54 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -269,6 +269,7 @@ sig val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_bitfield: Cil.ikind -> t -> (int_t * int_t) -> t val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t diff --git a/tests/regression/82-bitfield/10-refine-interval.c b/tests/regression/82-bitfield/10-refine-interval.c new file mode 100644 index 0000000000..d49e9937de --- /dev/null +++ b/tests/regression/82-bitfield/10-refine-interval.c @@ -0,0 +1,19 @@ +// PARAM: --enable ana.int.interval --enable ana.int.bitfield --set ana.int.refinement fixpoint --trace inv --trace branch --trace invariant +#include + +int main() { + unsigned char r; // non-neg rand + char x = r % 64; + + if ((r | x) == 0) { + __goblint_check(r == 0); // SUCCESS + __goblint_check(x == 0); // SUCCESS + } + + if ((r & x) == 63) { + __goblint_check(r & 63 == 63); // SUCCESS + __goblint_check(x == 63); // SUCCESS + } + + +} From f237a9e7cc28637113e01e2aca3cec6726163ee9 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Mon, 9 Dec 2024 10:09:30 +0100 Subject: [PATCH 081/111] shift_right and shift_left return bot when the result or the parameters are undefined + qcheck tests for bitshifts: https://wiki.sei.cmu.edu/confluence/display/c/INT34-C.+Do+not+shift+an+expression+by+a+negative+number+of+bits+or+by+greater+than+or+equal+to+the+number+of+bits+that+exist+in+the+operand --- src/cdomain/value/cdomains/intDomain.ml | 122 +++++++++++++----------- tests/unit/cdomains/intDomainTest.ml | 105 +++++++++++++------- 2 files changed, 135 insertions(+), 92 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 09d40084e4..6e400d2b2e 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1083,7 +1083,7 @@ struct let project ik p t = t end -module BitfieldInfixOps (Ints_t : IntOps.IntOps) = struct +module InfixIntOps (Ints_t : IntOps.IntOps) = struct let (&:) = Ints_t.logand let (|:) = Ints_t.logor let (^:) = Ints_t.logxor @@ -1106,7 +1106,7 @@ end (* Bitfield arithmetic, without any overflow handling etc. *) module BitfieldArith (Ints_t : IntOps.IntOps) = struct - include BitfieldInfixOps (Ints_t) + include InfixIntOps (Ints_t) let zero_mask = Ints_t.zero let one_mask = !:zero_mask @@ -1141,12 +1141,12 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let logor (z1,o1) (z2,o2) = (z1 &: z2, o1 |: o2) - let make_bitone_msk pos = Ints_t.one <<: pos - let make_lsb_bitmask pos = - let bitmsk = make_bitone_msk pos in - if bitmsk =: Ints_t.zero then Ints_t.zero - else Ints_t.sub bitmsk Ints_t.one - let make_msb_bitmask pos = !:(make_lsb_bitmask pos) + let bitmask_up_to pos = + let top_bit = Ints_t.one <<: pos in + if top_bit =: Ints_t.zero + then Ints_t.zero + else + Ints_t.sub top_bit Ints_t.one let get_bit bf pos = Ints_t.one &: (bf >>: pos) @@ -1164,7 +1164,6 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct if isSigned ik && isPositive then Ints_t.to_bigint(signMask &: o) else Ints_t.to_bigint o - (* Worst Case asymptotic runtime: O(2^n). *) let rec concretize (z,o) = if is_const (z,o) then [o] else @@ -1177,63 +1176,50 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let concretize bf = List.map Ints_t.to_int (concretize bf) - let get_o (_,o) = Ints_t.to_int o - - let shift_right_action ik (z,o) c = - let sign_msk = make_msb_bitmask (Size.bit ik - c) in - if (isSigned ik) && (o <: Ints_t.zero) then - (z >>: c, (o >>: c) |: sign_msk) + let shift_right ik (z,o) c = + let sign_mask = !:(bitmask_up_to (Size.bit ik - c)) in + if isSigned ik && o <: Ints_t.zero then + (z >>: c, (o >>: c) |: sign_mask) else - ((z >>: c) |: sign_msk, o >>: c) + ((z >>: c) |: sign_mask, o >>: c) let shift_right ik (z1, o1) (z2, o2) = if is_const (z2, o2) then - shift_right_action ik (z1, o1) (Ints_t.to_int o2) + shift_right ik (z1, o1) (Ints_t.to_int o2) else - let max_bit = Z.log2up (Z.of_int (Size.bit ik)) in - let mask_usefull_bits = !:(one_mask<<:max_bit) in - let concrete_values = concretize ((z2 &: mask_usefull_bits), (o2 &: mask_usefull_bits)) in - if (((o2 &: mask_usefull_bits) == Ints_t.of_int 0) && (z2 != one_mask)) || (List.length concrete_values) == 0 - then - (one_mask, zero_mask) - else - let (v1, v2) = (ref zero_mask, ref zero_mask) in - List.iter (fun x -> let (a, b) = (shift_right_action ik (z1, o1) x) in - v1 := !v1 |: a; - v2 := !v2 |: b - ) concrete_values; - (!v1, !v2) + let top_bit = Z.log2up (Z.of_int @@ Size.bit ik) in + let relevant_bits = bitmask_up_to top_bit in + let skipped_bits = !:relevant_bits in + let shift_counts = concretize (z2 |: skipped_bits, o2 &: relevant_bits) + in + List.fold_left (fun acc c -> + let next = shift_right ik (z1, o1) c in join acc next + ) (zero_mask, zero_mask) shift_counts - let shift_left_action _ (z,o) c = - let z_msk = make_lsb_bitmask c in - ((z <<: c) |: z_msk, o <<: c) + let shift_left _ (z,o) c = + let zero_mask = bitmask_up_to c in + ((z <<: c) |: zero_mask, o <<: c) let shift_left ik (z1, o1) (z2, o2) = - (* (one_mask, Ints_t.of_int (Size.bit ik)) *) if is_const (z2, o2) then - shift_left_action ik (z1, o1) (Ints_t.to_int o2) + shift_left ik (z1, o1) (Ints_t.to_int o2) else - let max_bit = Z.log2up (Z.of_int (Size.bit ik)) in - let mask_usefull_bits = !:(one_mask <<: max_bit) in - let concrete_values = concretize ((z2 &: mask_usefull_bits), (o2 &: mask_usefull_bits)) in - if (((o2 &: mask_usefull_bits) == Ints_t.of_int 0) && (z2 != one_mask)) || (List.length concrete_values) == 0 - then - (one_mask, zero_mask) - else - let (v1, v2) = (ref zero_mask, ref zero_mask) in - List.iter (fun x -> let (a, b) = (shift_left_action ik (z1, o1) x) in - v1 := !v1 |: a; - v2 := !v2 |: b - ) concrete_values; - (!v1, !v2) + let top_bit = Z.log2up (Z.of_int (Size.bit ik)) in + let relevant_bits = bitmask_up_to top_bit in + let skipped_bits = !:relevant_bits in + let shift_counts = concretize (z2 |: skipped_bits, o2 &: relevant_bits) + in + List.fold_left (fun acc c -> + let next = shift_left ik (z1, o1) c in join acc next + ) (zero_mask, zero_mask) shift_counts end module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct - include BitfieldInfixOps (Ints_t) + include InfixIntOps (Ints_t) let name () = "bitfield" type int_t = Ints_t.t @@ -1377,15 +1363,37 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst + let precision ik = if isSigned ik then Size.bit ik - 1 else Size.bit ik + let exclude_undefined_bitshifts ik (z,o) = + let mask = BArith.bitmask_up_to (precision ik) in + (z |: !:mask, o &: mask) + + let shift_right ik a b = - M.trace "bitfield" "shift_right"; - if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) - else norm ik (BArith.shift_right ik a b) + if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; + let shift_operation_is_undefined = BArith.is_invalid b + || BArith.is_invalid a + || (isSigned ik && BArith.min ik b < Z.zero) + || (Z.to_int @@ BArith.min ik b > precision ik) + in + if shift_operation_is_undefined + then + (bot (), {underflow=false; overflow=false}) + else + norm ik @@ BArith.shift_right ik a (exclude_undefined_bitshifts ik b) let shift_left ik a b = - M.trace "bitfield" "shift_left"; - if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) - else norm ik (BArith.shift_left ik a b) + if M.tracing then M.trace "bitfield" "%a << %a" pretty a pretty b; + let shift_operation_is_undefined = BArith.is_invalid b + || BArith.is_invalid a + || (isSigned ik && BArith.min ik b < Z.zero) + || (Z.to_int @@ BArith.min ik b > precision ik) + in + if shift_operation_is_undefined + then + (bot (), {underflow=false; overflow=false}) + else + norm ik @@ BArith.shift_left ik a (exclude_undefined_bitshifts ik b) (* Arith *) @@ -1512,7 +1520,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let starting ?(suppress_ovwarn=false) ik n = if Ints_t.compare n Ints_t.zero >= 0 then (* sign bit can only be 0, as all numbers will be positive *) - let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in + let signBitMask = Ints_t.one <<: (Size.bit ik - 1) in let zs = BArith.one_mask in let os = !:signBitMask &: BArith.one_mask in (norm ~suppress_ovwarn ik @@ (zs,os)) @@ -1522,7 +1530,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let ending ?(suppress_ovwarn=false) ik n = if isSigned ik && Ints_t.compare n Ints_t.zero <= 0 then (* sign bit can only be 1, as all numbers will be negative *) - let signBitMask = BArith.make_bitone_msk (Size.bit ik - 1) in + let signBitMask = Ints_t.one <<: (Size.bit ik - 1) in let zs = !:signBitMask &: BArith.one_mask in let os = BArith.one_mask in (norm ~suppress_ovwarn ik @@ (zs,os)) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index b3de4fe99f..b884dcd1ba 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -256,6 +256,7 @@ struct let ik = Cil.IInt let ik_char = Cil.IChar + let ik_uchar = Cil.IUChar let assert_equal x y = OUnit.assert_equal ~printer:I.show x y @@ -468,42 +469,76 @@ struct assert_bool "-5 ?= not (4 | 12)" (I.equal_to (of_int (-5)) (I.lognot ik b12) = `Top) let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is + let cart_op op a b = List.map (BatTuple.Tuple2.uncurry op) (BatList.cartesian_product a b) - let assert_shift shift symb ik a b expected_values = - let bf1 = of_list ik (List.map of_int a) in - let bf2 = of_list ik (List.map of_int b) in - let bf_shift_resolution = (shift ik bf1 bf2) in - let x = of_list ik (List.map of_int expected_values) in - let output_string = I.show bf1 ^ symb ^ I.show bf2 ^ " was: " ^ I.show bf_shift_resolution ^ " but should be: " ^ I.show x in - let output = "Test shift ("^ I.show bf1 ^ symb ^ I.show bf2 ^ ") failed: " ^ output_string in - assert_bool (output) (I.equal bf_shift_resolution x) + let assert_shift shift ik a b expected = + let symb, shift_op_bf, shift_op_int = match shift with + | `L -> " << ", I.shift_left ik, Int.shift_left + | `R -> " >> ", I.shift_right ik, Int.shift_right + in + let bf_a = of_list ik (List.map of_int a) in + let bf_b = of_list ik (List.map of_int b) in + let result = (shift_op_bf bf_a bf_b) in + let expected = match expected with + | `B bf -> bf + | `I is -> of_list ik (List.map of_int is) + in + let output_string = "was: " ^ I.show result ^ " but should be: " ^ I.show expected in + let output_string = "Test shift ("^ I.show bf_a ^ symb ^ I.show bf_b ^ ") failed: " ^ output_string in + assert_bool output_string (I.equal result expected) + + let assert_shift_left ik a b expected = assert_shift `L ik a b expected + let assert_shift_right ik a b expected = assert_shift `R ik a b expected + + let list_from_set_gen gen = + let open QCheck2.Gen in + let module S = Set.Make(Int) in + list gen >>= fun lst -> + let set = List.fold_left (fun acc x -> S.add x acc) S.empty lst in + return (S.elements set) + + let test_shift ik name c_op a_op = + let shift_test_printer (a,b) = Printf.sprintf "a: [%s], b: [%s]" + (String.concat ", " (List.map string_of_int a)) + (String.concat ", " (List.map string_of_int b)) + in + let of_list ik is = of_list ik (List.map of_int is) in + let open QCheck2 in + let a_gen = + list_from_set_gen Gen.small_signed_int + in + let b_gen = + let precision = snd @@ IntDomain.Size.bits ik in + list_from_set_gen (Gen.int_range 0 precision) + in + Test.make ~name:name ~print:shift_test_printer (Gen.pair a_gen b_gen) + (fun (a,b) -> + let expected = cart_op c_op a b |> of_list ik in + let result = a_op ik (of_list ik a) (of_list ik b) in + let test_result = I.equal result expected in + test_result + ) - let assert_shift_left ik a b res = assert_shift I.shift_left " << " ik a b res - let assert_shift_right ik a b res = assert_shift I.shift_right " >> " ik a b res + let test_shift_left = QCheck_ounit.to_ounit2_test (test_shift ik "test shift left" Int.shift_left I.shift_left) + let test_shift_right = QCheck_ounit.to_ounit2_test (test_shift ik "test shift right" Int.shift_right I.shift_right) - let test_shift_left _ = - assert_shift_left ik_char [-3] [7] [-128]; - assert_shift_left ik [-3] [7] [-384]; - assert_shift_left ik [2] [1; 2] [2; 4; 8; 16]; - assert_shift_left ik [1; 2] [1] [2; 4]; - assert_shift_left ik [-1; 1] [1] [-2; 2]; - assert_shift_left ik [-1] [4] [-16]; - assert_shift_left ik [-1] [1] [-2]; - assert_shift_left ik [-1] [2] [-4]; - assert_shift_left ik [-1] [3] [-8]; - assert_shift_left ik [-2] [1; 2] [-2; -4; -8; -16]; - assert_shift_left ik [-1] [1; 2] [-1; -2; -4; -8]; - assert_shift_left ik [1073741824] [128; 384] [0]; - assert_shift_left ik [1073741824] [0; 128; 384] [1073741824] - - let test_shift_right _ = - assert_shift_right ik [4] [1] [2]; - assert_shift_right ik [-4] [1] [-2]; - assert_shift_right ik [1] [1] [0]; - assert_shift_right ik [1] [1; 2] [0; 1]; - assert_shift_right ik [1; 2] [1; 2] [0; 1; 2; 3]; - assert_shift_right ik [32] [64; 2] [8; 32]; - assert_shift_right ik [32] [128; 384] [0] + let test_shift_left = [ + test_shift_left; + "shift left edge cases" >:: fun _ -> + assert_shift_left ik_char [85] [4; 6] (`B (I.bot ())); + + assert_shift_left ik [1073741824] [1; 128; 384] (`B (I.bot ())); + assert_shift_left ik [1073741824] [0; 128; 384] (`I [1073741824]) + ] + + let test_shift_right = [ + test_shift_right; + "shift right edge cases" >:: fun _ -> + assert_shift_right ik_char [85] [8] (`B (I.bot ())); + assert_shift_right ik_uchar [85] [9] (`B (I.bot ())); + + assert_shift_right ik [32] [128; 384] (`B (I.bot ())) + ] (* Arith *) @@ -763,8 +798,8 @@ struct "test_logor" >:: test_logor; "test_lognot" >:: test_lognot; - "test_shift_left" >:: test_shift_left; - "test_shift_right" >:: test_shift_right; + "test_shift_left" >::: test_shift_left; + "test_shift_right" >::: test_shift_right; "test_add" >:: test_add; "test_sub" >:: test_sub; From e4eefd93cbc24e8cb4fda0fe04d566d060d33950 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Mon, 9 Dec 2024 18:45:05 +0100 Subject: [PATCH 082/111] added to_bitfield to refine base invariant further and regression test --- src/analyses/baseInvariant.ml | 30 ++++-- src/cdomain/value/cdomains/intDomain.ml | 94 ++++++++++++++++++- src/cdomain/value/cdomains/intDomain.mli | 2 + .../82-bitfield/10-refine-interval.c | 3 + .../82-bitfield/11-refine-interval2.c | 17 ++++ 5 files changed, 136 insertions(+), 10 deletions(-) create mode 100644 tests/regression/82-bitfield/11-refine-interval2.c diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 950fd6f236..08f96a6185 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -398,7 +398,16 @@ struct | BOr -> (* Be careful: inv_exp performs a meet on both arguments of the BOr / BXor. *) if PrecisionUtil.get_bitfield () then - ID.meet a (ID.logand a c), ID.meet b (ID.logand b c) + let a', b' = ID.meet a (ID.logand a c), ID.meet b (ID.logand b c) in + let (cz, co) = ID.to_bitfield ikind c in + let (az, ao) = ID.to_bitfield ikind a' in + let (bz, bo) = ID.to_bitfield ikind b' in + let cDef1 = Z.logand co (Z.lognot cz) in + let aDef0 = Z.logand az (Z.lognot ao) in + let bDef0 = Z.logand bz (Z.lognot bo) in + let az = Z.logand az (Z.lognot (Z.logand bDef0 cDef1)) in + let bz = Z.logand bz (Z.lognot (Z.logand aDef0 cDef1)) in + ID.meet a' (ID.of_bitfield ikind (az, ao)), ID.meet b' (ID.of_bitfield ikind (bz, bo)) else a, b | BXor -> (* Be careful: inv_exp performs a meet on both arguments of the BOr / BXor. *) @@ -412,7 +421,7 @@ struct meet_bin c c else a, b - | BAnd as op -> + | BAnd -> (* we only attempt to refine a here *) let a = match ID.to_int b with @@ -420,11 +429,20 @@ struct (match ID.to_bool c with | Some true -> ID.meet a (ID.of_congruence ikind (Z.one, Z.of_int 2)) | Some false -> ID.meet a (ID.of_congruence ikind (Z.zero, Z.of_int 2)) - | None -> if M.tracing then M.tracel "inv" "Unhandled case for operator x %a 1 = %a" d_binop op ID.pretty c; a) - | _ -> if M.tracing then M.tracel "inv" "Unhandled case for operator x %a %a = %a" d_binop op ID.pretty b ID.pretty c; a + | None -> a) + | _ -> a in - if PrecisionUtil.get_bitfield () then - ID.meet a (ID.logor a c), ID.meet b (ID.logor b c) + if PrecisionUtil.get_bitfield () then + let a', b' = ID.meet a (ID.logor a c), ID.meet b (ID.logor b c) in + let (cz, co) = ID.to_bitfield ikind c in + let (az, ao) = ID.to_bitfield ikind a' in + let (bz, bo) = ID.to_bitfield ikind b' in + let cDef0 = Z.logand cz (Z.lognot co) in + let aDef1 = Z.logand ao (Z.lognot az) in + let bDef1 = Z.logand bo (Z.lognot bz) in + let ao = Z.logand ao (Z.lognot (Z.logand bDef1 cDef0)) in + let bo = Z.logand bo (Z.lognot (Z.logand aDef1 cDef0)) in + ID.meet a' (ID.of_bitfield ikind (az, ao)), ID.meet b' (ID.of_bitfield ikind (bz, bo)) else a, b | op -> if M.tracing then M.tracel "inv" "Unhandled operator %a" d_binop op; diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 2a9ae32562..d2c92415ff 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -262,6 +262,7 @@ sig val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t val of_bitfield: Cil.ikind -> int_t * int_t -> t + val to_bitfield: Cil.ikind -> t -> int_t * int_t val is_top_of: Cil.ikind -> t -> bool val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t @@ -314,6 +315,7 @@ sig val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t val of_bitfield: Cil.ikind -> int_t * int_t -> t + val to_bitfield: Cil.ikind -> t -> int_t * int_t val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t @@ -393,6 +395,7 @@ struct let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} let of_bitfield ikind (z,o) = {v = I.of_bitfield ikind (z,o); ikind} + let to_bitfield ikind x = I.to_bitfield ikind x.v let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} @@ -779,6 +782,45 @@ struct let one = Some IArith.one let top_bool = Some IArith.top_bool + let to_bitfield ik z = + match z with None -> (Ints_t.lognot Ints_t.zero, Ints_t.lognot Ints_t.zero) | Some (x,y) -> + let (min_ik, max_ik) = Size.range ik in + let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in + let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in + + let rec analyze_bits pos (acc_z, acc_o) = + if pos < 0 then (acc_z, acc_o) + else + let position = Ints_t.shift_left Ints_t.one pos in + let mask = Ints_t.sub position Ints_t.one in + let remainder = Ints_t.logand startv mask in + + let without_remainder = Ints_t.sub startv remainder in + let bigger_number = Ints_t.add without_remainder position in + + let bit_status = + if Ints_t.compare bigger_number endv <= 0 then + `top + else + if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then + `one + else + `zero + in + + let new_acc = + match bit_status with + | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) + | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) + | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) + + in + analyze_bits (pos - 1) new_acc + in + let result = analyze_bits (Size.bit ik - 1) (Ints_t.zero, Ints_t.zero) in + let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) + in casted + let of_bool _ik = function true -> one | false -> zero let to_bool (a: t) = match a with | None -> None @@ -1379,7 +1421,20 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) in norm ~debug:true ~suppress_ovwarn ik casted - let of_congruence ik (c,m) = (if m = Ints_t.zero then fst (of_int ik c) else top_of ik) + let of_bitfield ik x = norm ik x |> fst + + let to_bitfield ik x = norm ik x |> fst + + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) + + let of_congruence ik (c,m) = + if m = Ints_t.zero then of_int ik c |> fst + else if is_power_of_two m then + let mod_mask = m -: Ints_t.one in + let z = !: c in + let o = !:mod_mask |: c in + norm ik (z,o) |> fst + else top_of ik let of_bool _ik = function true -> BArith.one | false -> BArith.zero @@ -1561,11 +1616,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let (min_ik, max_ik) = Size.range ik in of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) - let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) - let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = match bf, cong with - | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> + | (z,o), Some (c,m) when m = Ints_t.zero -> norm ik (!: c, c) |> fst + | (z,o), Some (c,m) when is_power_of_two m && m <> Ints_t.one -> let congruenceMask = !:m in let newz = (!:congruenceMask &: z) |: (congruenceMask &: !:c) in let newo = (!:congruenceMask &: o) |: (congruenceMask &: c) in @@ -1860,6 +1914,13 @@ struct else o in fst (norm_interval ik (min ik x, max ik x)) + let to_bitfield ik x = + let joinbf (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) in + let rec from_list is acc = match is with + [] -> acc | + j::js -> from_list js (joinbf acc (Interval.to_bitfield ik (Some j))) + in from_list x (Ints_t.zero, Ints_t.zero) + let of_int ik (x: int_t) = of_interval ik (x, x) let lt ik x y = @@ -2720,6 +2781,10 @@ struct let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in norm ik @@ (`Excluded (ex, r)) + let to_bitfield ik x = + let one_mask = Z.lognot Z.zero + in (one_mask, one_mask) + let starting ?(suppress_ovwarn=false) ikind x = let _,u_ik = Size.range ikind in of_interval ~suppress_ovwarn ikind (x, u_ik) @@ -3209,6 +3274,10 @@ module Enums : S with type int_t = Z.t = struct let is_excl_list = BatOption.is_some % to_excl_list let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None + let to_bitfield ik x = + let one_mask = Z.lognot Z.zero + in (one_mask, one_mask) + let starting ?(suppress_ovwarn=false) ikind x = let _,u_ik = Size.range ikind in of_interval ~suppress_ovwarn ikind (x, u_ik) @@ -3469,6 +3538,17 @@ struct let of_congruence ik (c,m) = normalize ik @@ Some(c,m) + let to_bitfield ik x = + let is_power_of_two x = (Z.logand x (x -: Z.one) = Z.zero) in + match x with None -> (Z.zero, Z.zero) | Some (c,m) -> + if m = Z.zero then (Z.lognot c, c) + else if is_power_of_two m then + let mod_mask = m -: Z.one in + let z = Z.lognot c in + let o = Z.logor (Z.lognot mod_mask) c in + (z,o) + else (Z.lognot Z.zero, Z.lognot Z.zero) + let maximal t = match t with | Some (x, y) when y =: Z.zero -> Some x | _ -> None @@ -4101,6 +4181,12 @@ module IntDomTupleImpl = struct in mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge + let to_bitfield ik x = + let bf_meet (z1,o1) (z2,o2) = (Z.logand z1 z2, Z.logand o1 o2) in + let bf_top = (Z.lognot Z.zero, Z.lognot Z.zero) in + let res_tup = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_bitfield ik } x + in List.fold bf_meet bf_top (to_list res_tup) + let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in if n = 1 then Some (List.hd xs) else ( diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 55149cdb54..6c68724cc5 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -264,6 +264,7 @@ sig val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t val of_congruence: Cil.ikind -> int_t * int_t -> t val of_bitfield: Cil.ikind -> int_t * int_t -> t + val to_bitfield: Cil.ikind -> t -> int_t * int_t val is_top_of: Cil.ikind -> t -> bool val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t @@ -329,6 +330,7 @@ sig val of_congruence: Cil.ikind -> int_t * int_t -> t val of_bitfield: Cil.ikind -> int_t * int_t -> t + val to_bitfield: Cil.ikind -> t -> int_t * int_t val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t diff --git a/tests/regression/82-bitfield/10-refine-interval.c b/tests/regression/82-bitfield/10-refine-interval.c index d49e9937de..d9441f05e9 100644 --- a/tests/regression/82-bitfield/10-refine-interval.c +++ b/tests/regression/82-bitfield/10-refine-interval.c @@ -15,5 +15,8 @@ int main() { __goblint_check(x == 63); // SUCCESS } + if ((x ^ 3) == 5) { + __goblint_check(x == 6); // SUCCESS + } } diff --git a/tests/regression/82-bitfield/11-refine-interval2.c b/tests/regression/82-bitfield/11-refine-interval2.c new file mode 100644 index 0000000000..4abaac9b89 --- /dev/null +++ b/tests/regression/82-bitfield/11-refine-interval2.c @@ -0,0 +1,17 @@ +// PARAM: --enable ana.int.interval --enable ana.int.bitfield --set ana.int.refinement fixpoint --trace inv --trace branch --trace invariant +#include + +int main() { + unsigned char r; // non-neg rand + char x = r % 64; + + if ((x | 0) == 63) { + __goblint_check(x == 63); // SUCCESS + } + + if ((x & 63) == 0) { + __goblint_check(x == 0); // SUCCESS + } + + +} From 88b0dfc9d6729dcfd606e56132bcfe1061fd7949 Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Tue, 10 Dec 2024 17:24:09 +0100 Subject: [PATCH 083/111] hotfix regression tests --- .../{03-simple-bitwise-c => 03-simple-bitwise.c} | 0 tests/regression/82-bitfield/08-refine-with-bitfield.c | 8 +++----- .../{09-refine-interval.c => 09-refine-intervalA.c} | 6 +++--- .../{10-refine-interval.c => 10-refine-intervalB.c} | 0 .../{11-refine-interval2.c => 11-refine-intervalC.c} | 0 5 files changed, 6 insertions(+), 8 deletions(-) rename tests/regression/82-bitfield/{03-simple-bitwise-c => 03-simple-bitwise.c} (100%) rename tests/regression/82-bitfield/{09-refine-interval.c => 09-refine-intervalA.c} (76%) rename tests/regression/82-bitfield/{10-refine-interval.c => 10-refine-intervalB.c} (100%) rename tests/regression/82-bitfield/{11-refine-interval2.c => 11-refine-intervalC.c} (100%) diff --git a/tests/regression/82-bitfield/03-simple-bitwise-c b/tests/regression/82-bitfield/03-simple-bitwise.c similarity index 100% rename from tests/regression/82-bitfield/03-simple-bitwise-c rename to tests/regression/82-bitfield/03-simple-bitwise.c diff --git a/tests/regression/82-bitfield/08-refine-with-bitfield.c b/tests/regression/82-bitfield/08-refine-with-bitfield.c index 64cb588f2d..9ca687671c 100644 --- a/tests/regression/82-bitfield/08-refine-with-bitfield.c +++ b/tests/regression/82-bitfield/08-refine-with-bitfield.c @@ -43,7 +43,6 @@ int main() { // Testing OR operations with patterns int OR_MASK = 0x55; // 01010101 in binary if ((a | OR_MASK) == 0x55) { - __goblint_assert(a == 0); // Only possible if a is 0 __goblint_assert((a | 0xFF) == 0xFF); // ORing with all 1s gives all 1s } @@ -74,7 +73,7 @@ int main() { if ((a & SHIFT_MASK) == SHIFT_MASK) { __goblint_assert((a & 12) == 12); // Both bits must be set __goblint_assert(((a >> 2) & 3) == 3); // When shifted right, lowest bits must be 11 - __goblint_assert(((a << 2) & 12) == 12); // When shifted left, highest bits must be 1100 + __goblint_assert(((a << 2) & 48) == 48); // When shifted left, highest bits must be 11 } int SHIFTED = 0x7 << 3; // 111000 in binary @@ -89,10 +88,9 @@ int main() { } // Testing bitwise complement - int COMP_MASK = ~0xF0; // Complement of 11110000 + int COMP_MASK = ~0x0F; if ((a & COMP_MASK) == 0x0F) { - __goblint_assert((a & 0xF0) == 0); // Upper 4 bits must be 0 - __goblint_assert((a & 0x0F) == 0x0F); // Lower 4 bits must be all 1s + __goblint_check(0); // NOWARN (unreachable) } return 0; diff --git a/tests/regression/82-bitfield/09-refine-interval.c b/tests/regression/82-bitfield/09-refine-intervalA.c similarity index 76% rename from tests/regression/82-bitfield/09-refine-interval.c rename to tests/regression/82-bitfield/09-refine-intervalA.c index 69c24ea0e3..0ff9f3b9e3 100644 --- a/tests/regression/82-bitfield/09-refine-interval.c +++ b/tests/regression/82-bitfield/09-refine-intervalA.c @@ -11,10 +11,10 @@ int main() { if ((a & inv_mask) == 0) { __goblint_check(a <= 14); // SUCCESS - __goblint_check(a >= 1); // SUCCESS + __goblint_check(a >= 0); // SUCCESS - if (1 <= a && a <= 14) { - printf("a is in the interval [1, 14]\n"); + if (0 <= a && a <= 14) { + printf("a is in the interval [0, 14]\n"); } else { __goblint_check(0); // NOWARN (unreachable) } diff --git a/tests/regression/82-bitfield/10-refine-interval.c b/tests/regression/82-bitfield/10-refine-intervalB.c similarity index 100% rename from tests/regression/82-bitfield/10-refine-interval.c rename to tests/regression/82-bitfield/10-refine-intervalB.c diff --git a/tests/regression/82-bitfield/11-refine-interval2.c b/tests/regression/82-bitfield/11-refine-intervalC.c similarity index 100% rename from tests/regression/82-bitfield/11-refine-interval2.c rename to tests/regression/82-bitfield/11-refine-intervalC.c From 60fbbf5758987a96dc8456245f2e9f9e9c82a5ab Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Wed, 11 Dec 2024 01:40:37 +0100 Subject: [PATCH 084/111] improved property tests for bitshifts --- src/cdomain/value/cdomains/intDomain.ml | 34 +++------ tests/unit/cdomains/intDomainTest.ml | 96 ++++++++++++++++++------- 2 files changed, 80 insertions(+), 50 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 6e400d2b2e..e16962080c 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1188,11 +1188,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct then shift_right ik (z1, o1) (Ints_t.to_int o2) else - let top_bit = Z.log2up (Z.of_int @@ Size.bit ik) in - let relevant_bits = bitmask_up_to top_bit in - let skipped_bits = !:relevant_bits in - let shift_counts = concretize (z2 |: skipped_bits, o2 &: relevant_bits) - in + let shift_counts = concretize (z2, o2) in List.fold_left (fun acc c -> let next = shift_right ik (z1, o1) c in join acc next ) (zero_mask, zero_mask) shift_counts @@ -1206,11 +1202,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct then shift_left ik (z1, o1) (Ints_t.to_int o2) else - let top_bit = Z.log2up (Z.of_int (Size.bit ik)) in - let relevant_bits = bitmask_up_to top_bit in - let skipped_bits = !:relevant_bits in - let shift_counts = concretize (z2 |: skipped_bits, o2 &: relevant_bits) - in + let shift_counts = concretize (z2, o2) in List.fold_left (fun acc c -> let next = shift_left ik (z1, o1) c in join acc next ) (zero_mask, zero_mask) shift_counts @@ -1363,20 +1355,19 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst - let precision ik = if isSigned ik then Size.bit ik - 1 else Size.bit ik + let precision ik = snd @@ Size.bits ik let exclude_undefined_bitshifts ik (z,o) = - let mask = BArith.bitmask_up_to (precision ik) in + let mask = BArith.bitmask_up_to (Z.log2up (Z.of_int @@ precision ik)) in (z |: !:mask, o &: mask) + let is_invalid_shift_operation ik a b = BArith.is_invalid b + || BArith.is_invalid a + || (isSigned ik && BArith.min ik b < Z.zero) + || (Z.to_int @@ BArith.min ik b > precision ik) let shift_right ik a b = if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; - let shift_operation_is_undefined = BArith.is_invalid b - || BArith.is_invalid a - || (isSigned ik && BArith.min ik b < Z.zero) - || (Z.to_int @@ BArith.min ik b > precision ik) - in - if shift_operation_is_undefined + if is_invalid_shift_operation ik a b then (bot (), {underflow=false; overflow=false}) else @@ -1384,12 +1375,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_left ik a b = if M.tracing then M.trace "bitfield" "%a << %a" pretty a pretty b; - let shift_operation_is_undefined = BArith.is_invalid b - || BArith.is_invalid a - || (isSigned ik && BArith.min ik b < Z.zero) - || (Z.to_int @@ BArith.min ik b > precision ik) - in - if shift_operation_is_undefined + if is_invalid_shift_operation ik a b then (bot (), {underflow=false; overflow=false}) else diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index b884dcd1ba..6c5db7e53a 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -470,6 +470,17 @@ struct let of_list ik is = List.fold_left (fun acc x -> I.join ik acc (I.of_int ik x)) (I.bot ()) is let cart_op op a b = List.map (BatTuple.Tuple2.uncurry op) (BatList.cartesian_product a b) + let string_of_ik ik = match ik with + | Cil.IInt -> "int" + | Cil.IUInt -> "unsigned int" + | Cil.IChar -> "char" + | Cil.IUChar -> "unsigned char" + | Cil.IBool -> "bool" + | Cil.ILong -> "long" + | Cil.IULong -> "unsigned long" + | Cil.ILongLong -> "long long" + | Cil.IULongLong -> "unsigned long long" + | _ -> "undefined C primitive type" let assert_shift shift ik a b expected = let symb, shift_op_bf, shift_op_int = match shift with @@ -484,60 +495,93 @@ struct | `I is -> of_list ik (List.map of_int is) in let output_string = "was: " ^ I.show result ^ " but should be: " ^ I.show expected in - let output_string = "Test shift ("^ I.show bf_a ^ symb ^ I.show bf_b ^ ") failed: " ^ output_string in + let output_string = "Test " ^ string_of_ik ik ^ " shift ("^ I.show bf_a ^ symb ^ I.show bf_b ^ ") failed: " ^ output_string in assert_bool output_string (I.equal result expected) let assert_shift_left ik a b expected = assert_shift `L ik a b expected let assert_shift_right ik a b expected = assert_shift `R ik a b expected - let list_from_set_gen gen = + let gen_sized_set size_gen gen = (* TODO might reduce the size of the generated list *) let open QCheck2.Gen in - let module S = Set.Make(Int) in - list gen >>= fun lst -> - let set = List.fold_left (fun acc x -> S.add x acc) S.empty lst in - return (S.elements set) + map (List.sort_uniq Int.compare) (list_size size_gen gen) + (* + Checks the property: (U_{a in gamma a_bf, b in gamma b_bf} a shift b) leq (a_bf shift b_bf) + *) let test_shift ik name c_op a_op = - let shift_test_printer (a,b) = Printf.sprintf "a: [%s], b: [%s]" + let shift_test_printer (ik,a,b) = Printf.sprintf "(ik: %s) a: [%s] b: [%s]" + ( + string_of_ik ik + ) (String.concat ", " (List.map string_of_int a)) (String.concat ", " (List.map string_of_int b)) in let of_list ik is = of_list ik (List.map of_int is) in - let open QCheck2 in - let a_gen = - list_from_set_gen Gen.small_signed_int + let precision = snd @@ IntDomain.Size.bits ik in + let open QCheck2 in let open Gen in + let a_gen ik = + let min_ik, max_ik = Batteries.Tuple2.mapn Z.to_int (IntDomain.Size.range ik) in + gen_sized_set (1 -- precision) (min_ik -- max_ik) + in + let b_gen ik = + gen_sized_set (1 -- (Z.log2up (Z.of_int precision))) (0 -- precision) in - let b_gen = - let precision = snd @@ IntDomain.Size.bits ik in - list_from_set_gen (Gen.int_range 0 precision) + let test_case_gen = Gen.( + oneofl [Cil.IInt; Cil.IUInt; Cil.IChar; Cil.IUChar; Cil.IBool] + >>= fun ik -> triple (return ik) (a_gen ik) (b_gen ik) + ) in - Test.make ~name:name ~print:shift_test_printer (Gen.pair a_gen b_gen) - (fun (a,b) -> - let expected = cart_op c_op a b |> of_list ik in + Test.make ~name:name ~print:shift_test_printer ~count:1000 (*~collect:shift_test_printer*) + test_case_gen + (fun (ik,a,b) -> + let expected_subset = cart_op c_op a b |> of_list ik in let result = a_op ik (of_list ik a) (of_list ik b) in - let test_result = I.equal result expected in - test_result + I.leq expected_subset result ) let test_shift_left = QCheck_ounit.to_ounit2_test (test_shift ik "test shift left" Int.shift_left I.shift_left) let test_shift_right = QCheck_ounit.to_ounit2_test (test_shift ik "test shift right" Int.shift_right I.shift_right) - let test_shift_left = [ + let test_shift_left = + let bot = `B (I.bot ()) in + [ test_shift_left; "shift left edge cases" >:: fun _ -> - assert_shift_left ik_char [85] [4; 6] (`B (I.bot ())); + assert_shift_left ik [1] [1; 2] (`I [1; 2; 4; 8]); + + assert_shift_left ik [1] [-1] bot; + + assert_shift_left ik_char [85] [8] bot; + assert_shift_left ik_uchar [85] [9] bot; + assert_shift_left ik [Int.max_int] [Sys.int_size] bot; + assert_shift_left Cil.IUInt [Int.add Int.max_int Int.max_int] [Int.add Sys.int_size 1] bot; - assert_shift_left ik [1073741824] [1; 128; 384] (`B (I.bot ())); - assert_shift_left ik [1073741824] [0; 128; 384] (`I [1073741824]) + assert_shift_left ik_char [42] [8; 1] (`I [84]); + assert_shift_left ik_uchar [42] [9; 1] (`I [84]); + + assert_shift_left ik [42] [Sys.int_size; 1] (`I [84]); + assert_shift_left Cil.IUInt [42] [Int.add Sys.int_size 1; 1] (`I [84]); ] - let test_shift_right = [ + let test_shift_right = + let bot = `B (I.bot ()) in + [ test_shift_right; "shift right edge cases" >:: fun _ -> - assert_shift_right ik_char [85] [8] (`B (I.bot ())); - assert_shift_right ik_uchar [85] [9] (`B (I.bot ())); + assert_shift_right ik [10] [1; 2] (`I [10; 7; 5; 1]); + + assert_shift_right ik [2] [-1] bot; + + assert_shift_right ik_char [85] [8] bot; + assert_shift_right ik_uchar [85] [9] bot; + assert_shift_right ik [Int.max_int] [Sys.int_size] bot; + assert_shift_right Cil.IUInt [Int.add Int.max_int Int.max_int] [Int.add Sys.int_size 1] bot; + + assert_shift_right ik_char [42] [8; 1] (`I [21]); + assert_shift_right ik_uchar [42] [9; 1] (`I [21]); - assert_shift_right ik [32] [128; 384] (`B (I.bot ())) + assert_shift_right ik [42] [Sys.int_size; 1] (`I [21]); + assert_shift_right Cil.IUInt [42] [Int.add Sys.int_size 1; 1] (`I [21]); ] From ed27d3d699056e17ea98dd728edcc81a70b25e6e Mon Sep 17 00:00:00 2001 From: ManuelLerchner Date: Wed, 11 Dec 2024 04:28:43 +0100 Subject: [PATCH 085/111] fix show --- src/cdomain/value/cdomains/intDomain.ml | 50 +++++++++++++------------ 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 09d40084e4..766de6c6e4 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1247,35 +1247,39 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let bot_of ik = bot () let to_pretty_bits (z,o) = - let known_bits = BArith.bits_known (z,o) in - let invalid_bits = BArith.bits_invalid (z,o) in - let num_bits_to_print = Sys.word_size in - let rec to_pretty_bits' known_mask impossible_mask o_mask max_bits acc = - if max_bits < 0 then - if o_mask = Ints_t.zero && String.empty = acc - then "0" else acc - else if o_mask = Ints_t.zero then acc - else - let current_bit_known = known_mask &: Ints_t.one in - let current_bit_impossible = impossible_mask &: Ints_t.one in - let bit_value = o_mask &: Ints_t.one in - let next_bit_string = - if current_bit_impossible = Ints_t.one - then "⊥" - else if current_bit_known = Ints_t.one || current_bit_known = Ints_t.zero - then string_of_int (Ints_t.to_int bit_value) else "⊤" in - to_pretty_bits' (known_mask >>: 1) (impossible_mask >>: 1) (o_mask >>: 1) (max_bits - 1) (next_bit_string ^ acc) + let known_bitmask = ref (BArith.bits_known (z,o)) in + let invalid_bitmask = ref (BArith.bits_invalid (z,o)) in + let o_mask = ref o in + let z_mask = ref z in + + let rec to_pretty_bits' acc = + let current_bit_known = (!known_bitmask &: Ints_t.one) = Ints_t.one in + let current_bit_impossible = (!invalid_bitmask &: Ints_t.one) = Ints_t.one in + + let bit_value = !o_mask &: Ints_t.one in + let bit = + if current_bit_impossible then "⊥" + else if not current_bit_known then "⊤" + else Ints_t.to_string bit_value + in + + if (!o_mask = Ints_t.of_int (-1) || !o_mask = Ints_t.zero ) && (!z_mask = Ints_t.of_int (-1) || !z_mask = Ints_t.zero) then + let prefix = bit ^ "..." ^ bit in + prefix ^ acc + else + (known_bitmask := !known_bitmask >>: 1; + invalid_bitmask := !invalid_bitmask >>: 1; + o_mask := !o_mask >>: 1; + z_mask := !z_mask >>: 1; + to_pretty_bits' (bit ^ acc)) in - to_pretty_bits' known_bits invalid_bits o num_bits_to_print "" + "0b" ^ to_pretty_bits' "" let show t = if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in - if BArith.is_const t then - Format.sprintf "{%08X, %08X} (unique: %d)" (Ints_t.to_int z) (Ints_t.to_int o) (Ints_t.to_int o) - else - Format.sprintf "{%08X, %08X}" (Ints_t.to_int z) (Ints_t.to_int o) + Format.sprintf "{%s, (zs:%s, os:%s)}" (to_pretty_bits t) (Ints_t.to_string z) (Ints_t.to_string o) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) From dbe2e008676dcab29c05b6809ac3e3104b2ea9bd Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Wed, 11 Dec 2024 05:54:17 +0100 Subject: [PATCH 086/111] some property tests failed as generators were not constrained to the ik --- tests/unit/cdomains/intDomainTest.ml | 40 +++++++++++----------------- 1 file changed, 16 insertions(+), 24 deletions(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 6c5db7e53a..586611c4cc 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -475,11 +475,6 @@ struct | Cil.IUInt -> "unsigned int" | Cil.IChar -> "char" | Cil.IUChar -> "unsigned char" - | Cil.IBool -> "bool" - | Cil.ILong -> "long" - | Cil.IULong -> "unsigned long" - | Cil.ILongLong -> "long long" - | Cil.IULongLong -> "unsigned long long" | _ -> "undefined C primitive type" let assert_shift shift ik a b expected = @@ -498,21 +493,16 @@ struct let output_string = "Test " ^ string_of_ik ik ^ " shift ("^ I.show bf_a ^ symb ^ I.show bf_b ^ ") failed: " ^ output_string in assert_bool output_string (I.equal result expected) - let assert_shift_left ik a b expected = assert_shift `L ik a b expected - let assert_shift_right ik a b expected = assert_shift `R ik a b expected + let assert_shift_left = assert_shift `L + let assert_shift_right = assert_shift `R let gen_sized_set size_gen gen = (* TODO might reduce the size of the generated list *) let open QCheck2.Gen in map (List.sort_uniq Int.compare) (list_size size_gen gen) - (* - Checks the property: (U_{a in gamma a_bf, b in gamma b_bf} a shift b) leq (a_bf shift b_bf) - *) + (* Checks the property: (U_{a in gamma a_bf, b in gamma b_bf} a shift b) leq (a_bf shift b_bf) *) let test_shift ik name c_op a_op = - let shift_test_printer (ik,a,b) = Printf.sprintf "(ik: %s) a: [%s] b: [%s]" - ( - string_of_ik ik - ) + let shift_test_printer (a,b) = Printf.sprintf "a: [%s] b: [%s]" (String.concat ", " (List.map string_of_int a)) (String.concat ", " (List.map string_of_int b)) in @@ -524,28 +514,30 @@ struct gen_sized_set (1 -- precision) (min_ik -- max_ik) in let b_gen ik = - gen_sized_set (1 -- (Z.log2up (Z.of_int precision))) (0 -- precision) + gen_sized_set (1 -- (Z.log2up @@ Z.of_int precision)) (0 -- precision) in - let test_case_gen = Gen.( - oneofl [Cil.IInt; Cil.IUInt; Cil.IChar; Cil.IUChar; Cil.IBool] - >>= fun ik -> triple (return ik) (a_gen ik) (b_gen ik) - ) + let test_case_gen = Gen.pair (a_gen ik) (b_gen ik) in Test.make ~name:name ~print:shift_test_printer ~count:1000 (*~collect:shift_test_printer*) test_case_gen - (fun (ik,a,b) -> + (fun (a,b) -> let expected_subset = cart_op c_op a b |> of_list ik in let result = a_op ik (of_list ik a) (of_list ik b) in I.leq expected_subset result ) - let test_shift_left = QCheck_ounit.to_ounit2_test (test_shift ik "test shift left" Int.shift_left I.shift_left) - let test_shift_right = QCheck_ounit.to_ounit2_test (test_shift ik "test shift right" Int.shift_right I.shift_right) + let test_shift_left = List.fold_left (fun acc ik -> test_shift ik + (Printf.sprintf "test shift left (ik: %s)" (string_of_ik ik)) Int.shift_left I.shift_left :: acc + ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list + + let test_shift_right = List.fold_left (fun acc ik -> test_shift ik + (Printf.sprintf "test shift right (ik: %s)" (string_of_ik ik)) Int.shift_right I.shift_right :: acc + ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list let test_shift_left = let bot = `B (I.bot ()) in [ - test_shift_left; + "property test: shift left" >::: test_shift_left; "shift left edge cases" >:: fun _ -> assert_shift_left ik [1] [1; 2] (`I [1; 2; 4; 8]); @@ -566,7 +558,7 @@ struct let test_shift_right = let bot = `B (I.bot ()) in [ - test_shift_right; + "property test: shift right" >::: test_shift_right; "shift right edge cases" >:: fun _ -> assert_shift_right ik [10] [1; 2] (`I [10; 7; 5; 1]); From 810a966cc518dc4a0c2e81605009247067862c8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Wed, 11 Dec 2024 09:48:06 +0100 Subject: [PATCH 087/111] fixed overflow in norm --- src/cdomain/value/cdomains/intDomain.ml | 83 +++++++++++-------- .../82-bitfield/10-refine-interval.c | 3 +- .../82-bitfield/11-refine-interval2.c | 2 +- tests/unit/cdomains/intDomainTest.ml | 48 ++++++----- 4 files changed, 79 insertions(+), 57 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index d2c92415ff..0bf11fd570 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1197,7 +1197,11 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bits_invalid (z,o) = !:(z |: o) let is_const (z,o) = (z ^: o) =: one_mask - let is_invalid ik (z,o) = + + let is_invalid (z,o) = + not (!:(z |: o) = Ints_t.zero) + + let is_invalid_ikind ik (z,o) = let mask = !:(Ints_t.of_bigint (snd (Size.range ik))) in not ((!:(z |: o |: mask)) = Ints_t.zero) @@ -1295,7 +1299,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let top () = (BArith.one_mask, BArith.one_mask) let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = top () + let top_of ik = + if isSigned ik then top () + else (BArith.one_mask, Ints_t.of_bigint (snd (Size.range ik))) let bot_of ik = bot () let to_pretty_bits (z,o) = @@ -1330,36 +1336,49 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let range ik bf = (BArith.min ik bf, BArith.max ik bf) - let maximal (z,o) = let isPositive = z < Ints_t.zero in - if o < Ints_t.zero && isPositive then (match Ints_t.upper_bound with Some maxVal -> Some (maxVal &: o) | None -> None ) - else Some o + let maximal (z,o) = + if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some o + else None - let minimal (z,o) = let isNegative = o < Ints_t.zero in - if z < Ints_t.zero && isNegative then (match Ints_t.lower_bound with Some minVal -> Some (minVal |: (!:z)) | None -> None ) - else Some (!:z) + let minimal (z,o) = + if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some (!:z) + else None - let norm ?(debug=false) ?(suppress_ovwarn=false) ik (z,o) = - if BArith.is_invalid ik (z,o) then + let wrap ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + if isSigned ik then + let newz = (z &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit z (Size.bit ik - 1))) in + let newo = (o &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit o (Size.bit ik - 1))) in + (newz,newo) + else + let newz = z |: !:(Ints_t.of_bigint max_ik) in + let newo = o &: (Ints_t.of_bigint max_ik) in + (newz,newo) + + let norm ?(suppress_ovwarn=false) ?(ignore_invalid=false) ik (z,o) = + let is_invalid = if ignore_invalid then BArith.is_invalid_ikind ik (z,o) else BArith.is_invalid (z,o) in + if is_invalid then (bot (), {underflow=false; overflow=false}) else let (min_ik, max_ik) = Size.range ik in - let wrap ik (z,o) = - if isSigned ik then - let newz = (z &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit z (Size.bit ik - 1))) in - let newo = (o &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit o (Size.bit ik - 1))) in - (newz,newo) - else - let newz = z |: !:(Ints_t.of_bigint max_ik) in - let newo = o &: (Ints_t.of_bigint max_ik) in - (newz,newo) - in - let (min,max) = range ik (z,o) in - let underflow = Z.compare min min_ik < 0 in - let overflow = Z.compare max max_ik > 0 in + let isPos = z < Ints_t.zero in + let isNeg = o < Ints_t.zero in + let underflow = if isSigned ik then (((Ints_t.of_bigint min_ik) &: z) <> Ints_t.zero) && isNeg else isNeg in + + let overflow = (((!: (Ints_t.of_bigint max_ik)) &: o) <> Ints_t.zero) && isPos in let new_bitfield = wrap ik (z,o) in - if suppress_ovwarn then (new_bitfield, {underflow=false; overflow=false}) - else (new_bitfield, {underflow=underflow; overflow=overflow}) + let overflow_info = if suppress_ovwarn then {underflow=false; overflow=false} else {underflow=underflow; overflow=overflow} in + if not (underflow || overflow) then + ((z,o), overflow_info) + else if should_wrap ik then + (new_bitfield, overflow_info) + else if should_ignore_overflow ik then + (M.warn ~category:M.Category.Integer.overflow "Bitfield: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Top"; + (* (bot (), overflow_info)) *) + (top_of ik, overflow_info)) + else + (top (), overflow_info) let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst @@ -1419,7 +1438,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int in let result = analyze_bits (Size.bit ik - 1) (bot()) in let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) - in norm ~debug:true ~suppress_ovwarn ik casted + in (wrap ik casted, {underflow=false; overflow=false}) let of_bitfield ik x = norm ik x |> fst @@ -1477,12 +1496,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = M.trace "bitfield" "shift_right"; - if BArith.is_invalid ik b || BArith.is_invalid ik a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_right ik a b) let shift_left ik a b = M.trace "bitfield" "shift_left"; - if BArith.is_invalid ik b || BArith.is_invalid ik a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) + if BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) then (bot (), {underflow=false; overflow=false}) else norm ik (BArith.shift_left ik a b) (* Arith *) @@ -1512,10 +1531,6 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let (rv, rm) = add_paper pv pm qv qm in let o3 = rv |: rm in let z3 = !:rv |: rm in - (* let _ = print_endline (show (z3, o3)) in - let _ = (match maximal (z3,o3) with Some k -> print_endline (Ints_t.to_string k) | None -> print_endline "None") in - let _ = (match minimal (z3,o3) with Some k -> print_endline (Ints_t.to_string k) | None -> print_endline "None") in - let _ = (match Size.range ik with (a,b) -> print_endline ("(" ^ Z.to_string a ^ "; " ^ Z.to_string b ^ ")")) in *) norm ik (z3,o3) let sub ?no_ov ik (z1, o1) (z2, o2) = @@ -1531,7 +1546,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let rv = dv &: !:mu in let rm = mu in let o3 = rv |: rm in - let z3 = !:rv |: rm in + let z3 = !:rv |: rm in norm ik (z3, o3) let neg ?no_ov ik x = @@ -1619,7 +1634,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = match bf, cong with | (z,o), Some (c,m) when m = Ints_t.zero -> norm ik (!: c, c) |> fst - | (z,o), Some (c,m) when is_power_of_two m && m <> Ints_t.one -> + | (z,o), Some (c,m) when is_power_of_two m -> let congruenceMask = !:m in let newz = (!:congruenceMask &: z) |: (congruenceMask &: !:c) in let newo = (!:congruenceMask &: o) |: (congruenceMask &: c) in diff --git a/tests/regression/82-bitfield/10-refine-interval.c b/tests/regression/82-bitfield/10-refine-interval.c index d9441f05e9..50e414ba3b 100644 --- a/tests/regression/82-bitfield/10-refine-interval.c +++ b/tests/regression/82-bitfield/10-refine-interval.c @@ -1,5 +1,4 @@ -// PARAM: --enable ana.int.interval --enable ana.int.bitfield --set ana.int.refinement fixpoint --trace inv --trace branch --trace invariant -#include +// PARAM: --enable ana.int.interval --enable ana.int.bitfield --set ana.int.refinement fixpoint int main() { unsigned char r; // non-neg rand diff --git a/tests/regression/82-bitfield/11-refine-interval2.c b/tests/regression/82-bitfield/11-refine-interval2.c index 4abaac9b89..6dc63b2494 100644 --- a/tests/regression/82-bitfield/11-refine-interval2.c +++ b/tests/regression/82-bitfield/11-refine-interval2.c @@ -1,4 +1,4 @@ -// PARAM: --enable ana.int.interval --enable ana.int.bitfield --set ana.int.refinement fixpoint --trace inv --trace branch --trace invariant +// PARAM: --enable ana.int.interval --enable ana.int.bitfield --set ana.int.refinement fixpoint #include int main() { diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 7f9be62dbe..ebabb5499a 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -331,25 +331,25 @@ struct let test_wrap_1 _ = let z = of_int 31376 in - let b_uint8 = I.of_int IChar z in - let b_sint8 = I.of_int ISChar z in + let b_uint8 = I.of_int IUChar z in + let b_sint8 = I.of_int IUChar z in let b_uint16 = I.of_int IUShort z in - let b_sint16 = I.of_int IShort z in + let b_sint16 = I.of_int IUShort z in (* See https://www.simonv.fr/TypesConvert/?integers *) - assert_equal (I.of_int IChar (of_int 144)) b_uint8; - assert_equal (I.of_int ISChar (of_int (-112))) b_sint8; + assert_equal (I.of_int IUChar (of_int 144)) b_uint8; + assert_equal (I.of_int IUChar (of_int (-112))) b_sint8; assert_equal (I.of_int IUShort (of_int 31376)) b_uint16; - assert_equal (I.of_int IShort (of_int 31376)) b_sint16 + assert_equal (I.of_int IUShort (of_int 31376)) b_sint16 let test_wrap_2 _ = let z1 = of_int 30867 in let z2 = of_int 30870 in - let join_cast_unsigned = I.join IChar (I.of_int IChar z1) (I.of_int IChar z2) in + let join_cast_unsigned = I.join IUChar (I.of_int IUChar z1) (I.of_int IUChar z2) in - let expected_unsigned = I.join IChar (I.of_int IChar (of_int 147)) (I.of_int IChar (of_int 150)) in + let expected_unsigned = I.join IUChar (I.of_int IUChar (of_int 147)) (I.of_int IUChar (of_int 150)) in - let expected_signed = I.join IChar (I.of_int IChar (of_int (-106))) (I.of_int IChar (of_int (-109))) in + let expected_signed = I.join IUChar (I.of_int IUChar (of_int (-106))) (I.of_int IUChar (of_int (-109))) in assert_equal expected_unsigned join_cast_unsigned; assert_equal expected_signed join_cast_unsigned @@ -395,6 +395,7 @@ struct assert_bool "false" (I.equal_to (of_int 0) b2 = `Eq) let test_to_bool _ = + let ik = IUInt in let b1 = I.of_int ik (of_int 3) in let b2 = I.of_int ik (of_int (-6)) in let b3 = I.of_int ik (of_int 0) in @@ -414,8 +415,8 @@ struct let test_cast_to _ = let b1 = I.of_int ik (of_int 1234) in - assert_equal (I.of_int IChar (of_int (210))) (I.cast_to IChar b1); - assert_equal (I.of_int ISChar (of_int (-46))) (I.cast_to ISChar b1); + assert_equal (I.of_int IUChar (of_int (210))) (I.cast_to IUChar b1); + assert_equal (I.of_int IUChar (of_int (-46))) (I.cast_to IUChar b1); assert_equal (I.of_int IUInt128 (of_int 1234)) (I.cast_to IUInt128 b1) @@ -852,22 +853,29 @@ struct let of_list ik is = List.fold_left (fun acc x -> B.join ik acc (B.of_int ik x)) (B.bot ()) is let v1 = Z.of_int 0 - let v2 = Z.of_int 2 - let vr = Z.mul v1 v2 + let v2 = Z.of_int 0 + let vr = Z.add v1 v2 - let is = [-3;3] - let res = [0;13;26;39;52;65;78;91] + let is = [0;1] + let res = [0;-1] - let b1 = of_list ik (List.map Z.of_int is) - let b2 = B.of_int ik v2 + let b1 = B.of_int ik v1 + let b2 = of_list ik (List.map Z.of_int is) let br = of_list ik (List.map Z.of_int res) - let test_add _ = assert_equal ~cmp:B.leq ~printer:B.show br (B.mul ik b2 b1) + let bool_res = B.join ik (B.of_int ik Z.zero) (B.of_int ik Z.one) - let test_lt _ = assert_equal ~cmp:B.leq ~printer:B.show (B.join ik (B.of_int ik Z.zero) (B.of_int ik Z.one)) (B.lt ik b1 b2) + (* let _ = print_endline (B.show b1) + let _ = print_endline (B.show b2) + let _ = print_endline (B.show (B.sub ik b1 b2)) + let _ = print_endline (B.show br) *) + + let test_add _ = assert_equal ~cmp:B.leq ~printer:B.show br (B.sub ik b1 b2) + + let test_lt _ = assert_equal ~cmp:B.leq ~printer:B.show bool_res (B.lt ik b1 b2) let test () = [ - "test_lt" >:: test_lt; + "test_add" >:: test_add; ] end From d7b875516115fe7b1c7eff03873b59999fa94716 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Wed, 11 Dec 2024 09:56:06 +0100 Subject: [PATCH 088/111] renaming due to merge conflict --- .../82-bitfield/{10-refine-interval.c => 10-refine-intervalB.c} | 0 .../82-bitfield/{11-refine-interval2.c => 11-refine-intervalC.c} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename tests/regression/82-bitfield/{10-refine-interval.c => 10-refine-intervalB.c} (100%) rename tests/regression/82-bitfield/{11-refine-interval2.c => 11-refine-intervalC.c} (100%) diff --git a/tests/regression/82-bitfield/10-refine-interval.c b/tests/regression/82-bitfield/10-refine-intervalB.c similarity index 100% rename from tests/regression/82-bitfield/10-refine-interval.c rename to tests/regression/82-bitfield/10-refine-intervalB.c diff --git a/tests/regression/82-bitfield/11-refine-interval2.c b/tests/regression/82-bitfield/11-refine-intervalC.c similarity index 100% rename from tests/regression/82-bitfield/11-refine-interval2.c rename to tests/regression/82-bitfield/11-refine-intervalC.c From 686633add15a6b776784a34d3cba6edf78475c21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Wed, 11 Dec 2024 11:05:17 +0100 Subject: [PATCH 089/111] two bug fixes --- src/cdomain/value/cdomains/intDomain.ml | 2 +- tests/regression/82-bitfield/02-complex-arith.c | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index bc55c854e2..febed72662 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1341,7 +1341,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (newz,newo) let norm ?(suppress_ovwarn=false) ik (z,o) = - if BArith.is_invalid ik (z,o) then + if BArith.is_invalid (z,o) then (bot (), {underflow=false; overflow=false}) else let (min_ik, max_ik) = Size.range ik in diff --git a/tests/regression/82-bitfield/02-complex-arith.c b/tests/regression/82-bitfield/02-complex-arith.c index ff0db443ee..a1f718b86b 100644 --- a/tests/regression/82-bitfield/02-complex-arith.c +++ b/tests/regression/82-bitfield/02-complex-arith.c @@ -1,5 +1,6 @@ // PARAM: --disable ana.int.interval --disable ana.int.def_exc --enable ana.int.bitfield #include +#include int main() { int a; @@ -22,10 +23,10 @@ int main() { int c_add = a + b; if (c_add == 40) { - goblint_check(1); // reachable + __goblint_check(1); // reachable } if (c_add == 42) { - goblint_check(1); // reachable + __goblint_check(1); // reachable } if (c_add > 42 || c_add < 40) { __goblint_check(0); // NOWARN (unreachable) @@ -36,10 +37,10 @@ int main() { int c_minus = b - a; if (c_minus == 6) { - goblint_check(1); // reachable + __goblint_check(1); // reachable } if (c_minus == 4) { - goblint_check(1); // reachable + __goblint_check(1); // reachable } if (c_minus > 6 || c_minus < 4) { __goblint_check(0); // NOWARN (unreachable) @@ -50,10 +51,10 @@ int main() { int c_mult = a * b; if (c_mult == 391) { - goblint_check(1); // reachable + __goblint_check(1); // reachable } if (c_mult == 437) { - goblint_check(1); // reachable + __goblint_check(1); // reachable } // DIV From 4b3a0f8683095b89191a1b1d7c721ae24d46fd18 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Wed, 11 Dec 2024 11:38:49 +0100 Subject: [PATCH 090/111] improved logging --- tests/unit/cdomains/intDomainTest.ml | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 586611c4cc..893714c893 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -472,15 +472,15 @@ struct let cart_op op a b = List.map (BatTuple.Tuple2.uncurry op) (BatList.cartesian_product a b) let string_of_ik ik = match ik with | Cil.IInt -> "int" - | Cil.IUInt -> "unsigned int" + | Cil.IUInt -> "unsigned_int" | Cil.IChar -> "char" - | Cil.IUChar -> "unsigned char" + | Cil.IUChar -> "unsigned_char" | _ -> "undefined C primitive type" let assert_shift shift ik a b expected = let symb, shift_op_bf, shift_op_int = match shift with - | `L -> " << ", I.shift_left ik, Int.shift_left - | `R -> " >> ", I.shift_right ik, Int.shift_right + | `L -> "<<", I.shift_left ik, Int.shift_left + | `R -> ">>", I.shift_right ik, Int.shift_right in let bf_a = of_list ik (List.map of_int a) in let bf_b = of_list ik (List.map of_int b) in @@ -489,8 +489,11 @@ struct | `B bf -> bf | `I is -> of_list ik (List.map of_int is) in - let output_string = "was: " ^ I.show result ^ " but should be: " ^ I.show expected in - let output_string = "Test " ^ string_of_ik ik ^ " shift ("^ I.show bf_a ^ symb ^ I.show bf_b ^ ") failed: " ^ output_string in + let output_string = Printf.sprintf "test (%s) shift [%s] %s [%s] failed: was: [%s] but should be: [%s]" + (string_of_ik ik) + (I.show bf_a) symb (I.show bf_b) + (I.show result) (I.show expected) + in assert_bool output_string (I.equal result expected) let assert_shift_left = assert_shift `L @@ -527,18 +530,18 @@ struct ) let test_shift_left = List.fold_left (fun acc ik -> test_shift ik - (Printf.sprintf "test shift left (ik: %s)" (string_of_ik ik)) Int.shift_left I.shift_left :: acc + (Printf.sprintf "test_shift_left_ik_%s" (string_of_ik ik)) Int.shift_left I.shift_left :: acc ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list let test_shift_right = List.fold_left (fun acc ik -> test_shift ik - (Printf.sprintf "test shift right (ik: %s)" (string_of_ik ik)) Int.shift_right I.shift_right :: acc + (Printf.sprintf "test_shift_right_ik_%s" (string_of_ik ik)) Int.shift_right I.shift_right :: acc ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list let test_shift_left = let bot = `B (I.bot ()) in [ - "property test: shift left" >::: test_shift_left; - "shift left edge cases" >:: fun _ -> + "property_test_shift_left" >::: test_shift_left; + "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik [1] [1; 2] (`I [1; 2; 4; 8]); assert_shift_left ik [1] [-1] bot; @@ -558,8 +561,8 @@ struct let test_shift_right = let bot = `B (I.bot ()) in [ - "property test: shift right" >::: test_shift_right; - "shift right edge cases" >:: fun _ -> + "property_test_shift_right" >::: test_shift_right; + "shift_right_edge_cases" >:: fun _ -> assert_shift_right ik [10] [1; 2] (`I [10; 7; 5; 1]); assert_shift_right ik [2] [-1] bot; From dee9036abd1844aa4f9937ae9ab9f823134c1356 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Wed, 11 Dec 2024 11:47:56 +0100 Subject: [PATCH 091/111] overflow behavior cannot be checked by property tests --- tests/unit/cdomains/intDomainTest.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 893714c893..99bac5e427 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -510,7 +510,7 @@ struct (String.concat ", " (List.map string_of_int b)) in let of_list ik is = of_list ik (List.map of_int is) in - let precision = snd @@ IntDomain.Size.bits ik in + let precision = Int.pred @@ snd @@ IntDomain.Size.bits ik in let open QCheck2 in let open Gen in let a_gen ik = let min_ik, max_ik = Batteries.Tuple2.mapn Z.to_int (IntDomain.Size.range ik) in From d6e3f61ae9f711124f21bac717391b81d94be038 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Wed, 11 Dec 2024 12:58:27 +0100 Subject: [PATCH 092/111] more robust tests with a found bug --- tests/unit/cdomains/intDomainTest.ml | 51 ++++++++++++++++++---------- 1 file changed, 34 insertions(+), 17 deletions(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 99bac5e427..0ab1897f05 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -476,6 +476,10 @@ struct | Cil.IChar -> "char" | Cil.IUChar -> "unsigned_char" | _ -> "undefined C primitive type" + let precision ik = + let prec = snd @@ IntDomain.Size.bits ik in + if isSigned ik + then prec else Int.pred prec let assert_shift shift ik a b expected = let symb, shift_op_bf, shift_op_int = match shift with @@ -510,7 +514,7 @@ struct (String.concat ", " (List.map string_of_int b)) in let of_list ik is = of_list ik (List.map of_int is) in - let precision = Int.pred @@ snd @@ IntDomain.Size.bits ik in + let precision = precision ik in let open QCheck2 in let open Gen in let a_gen ik = let min_ik, max_ik = Batteries.Tuple2.mapn Z.to_int (IntDomain.Size.range ik) in @@ -537,6 +541,11 @@ struct (Printf.sprintf "test_shift_right_ik_%s" (string_of_ik ik)) Int.shift_right I.shift_right :: acc ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list + let over_precision_ik_char = Int.succ @@ precision ik_char + let over_precision_ik_uchar = Int.succ @@ precision ik_uchar + let over_precision_ik_int = Int.succ @@ precision ik + let over_precision_ik_uint = Int.succ @@ precision Cil.IUInt + let test_shift_left = let bot = `B (I.bot ()) in [ @@ -546,16 +555,20 @@ struct assert_shift_left ik [1] [-1] bot; - assert_shift_left ik_char [85] [8] bot; - assert_shift_left ik_uchar [85] [9] bot; - assert_shift_left ik [Int.max_int] [Sys.int_size] bot; - assert_shift_left Cil.IUInt [Int.add Int.max_int Int.max_int] [Int.add Sys.int_size 1] bot; + assert_shift_left ik_char [85] [over_precision_ik_char] bot; + assert_shift_left ik_uchar [85] [over_precision_ik_uchar] bot; + + assert_shift_left ik [Int.max_int] [over_precision_ik_int] bot; + assert_shift_left Cil.IUInt [Int.add Int.max_int Int.max_int] [over_precision_ik_uint] bot; + + assert_shift_left ik_uchar [42] [over_precision_ik_uchar] bot; + assert_shift_left ik_uchar [42] [over_precision_ik_uchar; 0] (`I [42]); + (*assert_shift_left ik_char [42] [over_precision_ik_char; 0] (`I [42]);*) (* TODO intended behavior? Join with zero alters the z mask! *) - assert_shift_left ik_char [42] [8; 1] (`I [84]); - assert_shift_left ik_uchar [42] [9; 1] (`I [84]); + (*assert_shift_left ik [42] [over_precision_ik_int; 0] (`I [42]);*) (* TODO intended behavior? Join with zero alters the z mask! *) + assert_shift_left Cil.IUInt [42] [over_precision_ik_uint; 0] (`I [42]); - assert_shift_left ik [42] [Sys.int_size; 1] (`I [84]); - assert_shift_left Cil.IUInt [42] [Int.add Sys.int_size 1; 1] (`I [84]); + (* TODO unit tests for overflow wrapping? *) ] let test_shift_right = @@ -567,16 +580,20 @@ struct assert_shift_right ik [2] [-1] bot; - assert_shift_right ik_char [85] [8] bot; - assert_shift_right ik_uchar [85] [9] bot; - assert_shift_right ik [Int.max_int] [Sys.int_size] bot; - assert_shift_right Cil.IUInt [Int.add Int.max_int Int.max_int] [Int.add Sys.int_size 1] bot; + assert_shift_right ik_char [85] [over_precision_ik_char] bot; + assert_shift_right ik_uchar [85] [over_precision_ik_uchar] bot; + + assert_shift_right ik [Int.max_int] [over_precision_ik_int] bot; + assert_shift_right Cil.IUInt [Int.succ @@ Int.add Int.max_int Int.max_int] [over_precision_ik_uint] bot; + + assert_shift_right ik_uchar [42] [over_precision_ik_uchar] bot; + assert_shift_right ik_uchar [42] [over_precision_ik_uchar; 0] (`I [42]); + (*assert_shift_right ik_char [42] [over_precision_ik_char; 0] (`I [42]);*) (* TODO intended behavior? Join with zero alters the z mask! *) - assert_shift_right ik_char [42] [8; 1] (`I [21]); - assert_shift_right ik_uchar [42] [9; 1] (`I [21]); + (* assert_shift_right ik [42] [over_precision_ik_int; 0] (`I [42]); *) (* TODO intended behavior? Join with zero alters the z mask! *) + assert_shift_right Cil.IUInt [42] [over_precision_ik_uint; 0] (`I [42]); - assert_shift_right ik [42] [Sys.int_size; 1] (`I [21]); - assert_shift_right Cil.IUInt [42] [Int.add Sys.int_size 1; 1] (`I [21]); + (* TODO unit tests for overflow wrapping? *) ] From e3145adf3918a56747646aa40acffa9162bc8f88 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Wed, 11 Dec 2024 17:59:32 +0100 Subject: [PATCH 093/111] revert to basic unit tests --- tests/unit/cdomains/intDomainTest.ml | 75 ++++++++++++---------------- 1 file changed, 32 insertions(+), 43 deletions(-) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 0ab1897f05..f1aa81a1de 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -255,6 +255,7 @@ struct module I = IntDomain.SOverflowUnlifter (I) let ik = Cil.IInt + let ik_uint = Cil.IUInt let ik_char = Cil.IChar let ik_uchar = Cil.IUChar @@ -476,23 +477,20 @@ struct | Cil.IChar -> "char" | Cil.IUChar -> "unsigned_char" | _ -> "undefined C primitive type" - let precision ik = - let prec = snd @@ IntDomain.Size.bits ik in - if isSigned ik - then prec else Int.pred prec + let precision ik = snd @@ IntDomain.Size.bits ik let assert_shift shift ik a b expected = let symb, shift_op_bf, shift_op_int = match shift with | `L -> "<<", I.shift_left ik, Int.shift_left | `R -> ">>", I.shift_right ik, Int.shift_right in - let bf_a = of_list ik (List.map of_int a) in - let bf_b = of_list ik (List.map of_int b) in - let result = (shift_op_bf bf_a bf_b) in - let expected = match expected with + let of_list (is: int list) : I.t = of_list ik (List.map of_int is) in + let get_param x : I.t = match x with | `B bf -> bf - | `I is -> of_list ik (List.map of_int is) + | `I is -> of_list is in + let bf_a, bf_b, expected = get_param a, get_param b, get_param expected in + let result = (shift_op_bf bf_a bf_b) in let output_string = Printf.sprintf "test (%s) shift [%s] %s [%s] failed: was: [%s] but should be: [%s]" (string_of_ik ik) (I.show bf_a) symb (I.show bf_b) @@ -521,7 +519,7 @@ struct gen_sized_set (1 -- precision) (min_ik -- max_ik) in let b_gen ik = - gen_sized_set (1 -- (Z.log2up @@ Z.of_int precision)) (0 -- precision) + gen_sized_set (1 -- (Z.log2up @@ Z.of_int precision)) (0 -- Int.pred precision) (* only shifts that are smaller than precision *) in let test_case_gen = Gen.pair (a_gen ik) (b_gen ik) in @@ -541,59 +539,50 @@ struct (Printf.sprintf "test_shift_right_ik_%s" (string_of_ik ik)) Int.shift_right I.shift_right :: acc ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list - let over_precision_ik_char = Int.succ @@ precision ik_char - let over_precision_ik_uchar = Int.succ @@ precision ik_uchar - let over_precision_ik_int = Int.succ @@ precision ik - let over_precision_ik_uint = Int.succ @@ precision Cil.IUInt + let over_precision ik = Int.succ @@ precision ik + let bot = `B (I.bot ()) let test_shift_left = - let bot = `B (I.bot ()) in [ "property_test_shift_left" >::: test_shift_left; "shift_left_edge_cases" >:: fun _ -> - assert_shift_left ik [1] [1; 2] (`I [1; 2; 4; 8]); - - assert_shift_left ik [1] [-1] bot; - - assert_shift_left ik_char [85] [over_precision_ik_char] bot; - assert_shift_left ik_uchar [85] [over_precision_ik_uchar] bot; + assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); + assert_shift_left ik (`I [1]) (`I [-1]) bot; + assert_shift_left ik bot (`I [1]) bot; + assert_shift_left ik (`I [1]) bot bot; + assert_shift_left ik bot bot bot; - assert_shift_left ik [Int.max_int] [over_precision_ik_int] bot; - assert_shift_left Cil.IUInt [Int.add Int.max_int Int.max_int] [over_precision_ik_uint] bot; + assert_shift_left ik (`I [1]) (`I [over_precision ik]) bot; + assert_shift_left ik_uint (`I [1]) (`I [over_precision ik_uint]) bot; - assert_shift_left ik_uchar [42] [over_precision_ik_uchar] bot; - assert_shift_left ik_uchar [42] [over_precision_ik_uchar; 0] (`I [42]); - (*assert_shift_left ik_char [42] [over_precision_ik_char; 0] (`I [42]);*) (* TODO intended behavior? Join with zero alters the z mask! *) - - (*assert_shift_left ik [42] [over_precision_ik_int; 0] (`I [42]);*) (* TODO intended behavior? Join with zero alters the z mask! *) - assert_shift_left Cil.IUInt [42] [over_precision_ik_uint; 0] (`I [42]); + assert_shift_left ik (`I [1]) (`I [over_precision ik; 0]) (`I [1]); + assert_shift_left ik_uint (`I [4]) (`I [precision ik_uint; 0]) (`I [4]); (* TODO unit tests for overflow wrapping? *) + (* TODO bitfields that contains shifts whose value are bigger than the precision of the ik *) ] let test_shift_right = - let bot = `B (I.bot ()) in [ "property_test_shift_right" >::: test_shift_right; "shift_right_edge_cases" >:: fun _ -> - assert_shift_right ik [10] [1; 2] (`I [10; 7; 5; 1]); - - assert_shift_right ik [2] [-1] bot; - - assert_shift_right ik_char [85] [over_precision_ik_char] bot; - assert_shift_right ik_uchar [85] [over_precision_ik_uchar] bot; + assert_shift_right ik (`I [10]) (`I [1; 2]) (`I [10; 7; 5; 1]); + assert_shift_right ik (`I [2]) (`I [-1]) bot; + assert_shift_right ik (`I [1]) (`I [-1]) bot; + assert_shift_right ik bot (`I [1]) bot; + assert_shift_right ik (`I [1]) bot bot; + assert_shift_right ik bot bot bot; - assert_shift_right ik [Int.max_int] [over_precision_ik_int] bot; - assert_shift_right Cil.IUInt [Int.succ @@ Int.add Int.max_int Int.max_int] [over_precision_ik_uint] bot; + let double_max_int = Int.add Int.max_int Int.max_int in - assert_shift_right ik_uchar [42] [over_precision_ik_uchar] bot; - assert_shift_right ik_uchar [42] [over_precision_ik_uchar; 0] (`I [42]); - (*assert_shift_right ik_char [42] [over_precision_ik_char; 0] (`I [42]);*) (* TODO intended behavior? Join with zero alters the z mask! *) + assert_shift_right ik (`I [Int.min_int]) (`I [over_precision ik]) bot; + assert_shift_right ik_uint (`I [Int.add Int.max_int Int.max_int]) (`I [over_precision ik_uint]) bot; - (* assert_shift_right ik [42] [over_precision_ik_int; 0] (`I [42]); *) (* TODO intended behavior? Join with zero alters the z mask! *) - assert_shift_right Cil.IUInt [42] [over_precision_ik_uint; 0] (`I [42]); + assert_shift_right ik (`I [Int.min_int]) (`I [over_precision ik; 0]) (`I [Int.min_int]); + assert_shift_right ik_uint (`I [double_max_int]) (`I [precision ik_uint]) (`I [double_max_int]); (* TODO unit tests for overflow wrapping? *) + (* TODO bitfields that contains shifts whose value are bigger than the precision of the ik *) ] From f09ead44f04858e51fc80b134f9ec4f51f4b4b92 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Thu, 12 Dec 2024 09:07:36 +0100 Subject: [PATCH 094/111] bug in exclude_undefined_bitshifts must be fixed or behavior defined --- src/cdomain/value/cdomains/intDomain.ml | 6 ++--- tests/unit/cdomains/intDomainTest.ml | 33 +++++++++++-------------- 2 files changed, 17 insertions(+), 22 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 15619911ff..4fb6660763 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1458,13 +1458,13 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let precision ik = snd @@ Size.bits ik let exclude_undefined_bitshifts ik (z,o) = - let mask = BArith.bitmask_up_to (Z.log2up (Z.of_int @@ precision ik)) in - (z |: !:mask, o &: mask) + let mask = BArith.bitmask_up_to (Z.log2up @@ Z.of_int @@ precision ik) in + (z |: !:mask, o &: mask) (* TODO bug here! *) let is_invalid_shift_operation ik a b = BArith.is_invalid b || BArith.is_invalid a || (isSigned ik && BArith.min ik b < Z.zero) - || (Z.to_int @@ BArith.min ik b > precision ik) + || (Z.to_int @@ BArith.min ik b > precision ik) (* TODO >= *) let shift_right ik a b = if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 0e94a59ec1..8e6cf806c3 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -478,7 +478,10 @@ struct | Cil.IChar -> "char" | Cil.IUChar -> "unsigned_char" | _ -> "undefined C primitive type" + let precision ik = snd @@ IntDomain.Size.bits ik + let over_precision ik = Int.succ @@ precision ik + let under_precision ik = Int.pred @@ precision ik let assert_shift shift ik a b expected = let symb, shift_op_bf, shift_op_int = match shift with @@ -492,7 +495,7 @@ struct in let bf_a, bf_b, expected = get_param a, get_param b, get_param expected in let result = (shift_op_bf bf_a bf_b) in - let output_string = Printf.sprintf "test (%s) shift [%s] %s [%s] failed: was: [%s] but should be: [%s]" + let output_string = Printf.sprintf "test (%s) shift %s %s %s failed: was: %s but should be: %s" (string_of_ik ik) (I.show bf_a) symb (I.show bf_b) (I.show result) (I.show expected) @@ -513,14 +516,13 @@ struct (String.concat ", " (List.map string_of_int b)) in let of_list ik is = of_list ik (List.map of_int is) in - let precision = precision ik in let open QCheck2 in let open Gen in let a_gen ik = let min_ik, max_ik = Batteries.Tuple2.mapn Z.to_int (IntDomain.Size.range ik) in - gen_sized_set (1 -- precision) (min_ik -- max_ik) + gen_sized_set (1 -- precision ik) (min_ik -- max_ik) in let b_gen ik = - gen_sized_set (1 -- (Z.log2up @@ Z.of_int precision)) (0 -- Int.pred precision) (* only shifts that are smaller than precision *) + gen_sized_set (1 -- (Z.log2up @@ Z.of_int @@ precision ik)) (0 -- under_precision ik) (* only shifts that are smaller than precision *) in let test_case_gen = Gen.pair (a_gen ik) (b_gen ik) in @@ -540,50 +542,43 @@ struct (Printf.sprintf "test_shift_right_ik_%s" (string_of_ik ik)) Int.shift_right I.shift_right :: acc ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list - let over_precision ik = Int.succ @@ precision ik - let bot = `B (I.bot ()) + let test_shift_left = [ "property_test_shift_left" >::: test_shift_left; "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); + assert_shift_left ik (`I [1]) (`I [-1]) bot; assert_shift_left ik bot (`I [1]) bot; assert_shift_left ik (`I [1]) bot bot; assert_shift_left ik bot bot bot; assert_shift_left ik (`I [1]) (`I [over_precision ik]) bot; - assert_shift_left ik_uint (`I [1]) (`I [over_precision ik_uint]) bot; - assert_shift_left ik (`I [1]) (`I [over_precision ik; 0]) (`I [1]); - assert_shift_left ik_uint (`I [4]) (`I [precision ik_uint; 0]) (`I [4]); - (* TODO unit tests for overflow wrapping? *) - (* TODO bitfields that contains shifts whose value are bigger than the precision of the ik *) + assert_shift_left ik_uint (`I [1]) (`I [over_precision ik_uint]) bot; + assert_shift_left ik_uint (`I [4]) (`I [over_precision ik_uint; 0]) (`I [4]); ] let test_shift_right = + let double_max_int = Int.add Int.max_int Int.max_int in [ "property_test_shift_right" >::: test_shift_right; "shift_right_edge_cases" >:: fun _ -> assert_shift_right ik (`I [10]) (`I [1; 2]) (`I [10; 7; 5; 1]); + assert_shift_right ik (`I [2]) (`I [-1]) bot; - assert_shift_right ik (`I [1]) (`I [-1]) bot; assert_shift_right ik bot (`I [1]) bot; assert_shift_right ik (`I [1]) bot bot; assert_shift_right ik bot bot bot; - let double_max_int = Int.add Int.max_int Int.max_int in - assert_shift_right ik (`I [Int.min_int]) (`I [over_precision ik]) bot; - assert_shift_right ik_uint (`I [Int.add Int.max_int Int.max_int]) (`I [over_precision ik_uint]) bot; - assert_shift_right ik (`I [Int.min_int]) (`I [over_precision ik; 0]) (`I [Int.min_int]); - assert_shift_right ik_uint (`I [double_max_int]) (`I [precision ik_uint]) (`I [double_max_int]); - (* TODO unit tests for overflow wrapping? *) - (* TODO bitfields that contains shifts whose value are bigger than the precision of the ik *) + assert_shift_right ik_uint (`I [double_max_int]) (`I [over_precision ik_uint]) bot; + assert_shift_right ik_uint (`I [double_max_int]) (`I [over_precision ik_uint; 0]) (`I [double_max_int]); ] From 8b53b08713f096562949deffdcd96c119396c66b Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Thu, 12 Dec 2024 17:27:08 +0100 Subject: [PATCH 095/111] Added distinction between invalid and undefined bitshifts. In the former case bot is returned and in the latter top. --- src/cdomain/value/cdomains/intDomain.ml | 11 ++++- tests/unit/cdomains/intDomainTest.ml | 55 ++++++++++++++++++------- 2 files changed, 50 insertions(+), 16 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4fb6660763..4ae2e76f8b 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1463,14 +1463,18 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let is_invalid_shift_operation ik a b = BArith.is_invalid b || BArith.is_invalid a - || (isSigned ik && BArith.min ik b < Z.zero) - || (Z.to_int @@ BArith.min ik b > precision ik) (* TODO >= *) + + let is_undefined_shift_operation ik a b = (isSigned ik && BArith.min ik b < Z.zero) + || (Z.to_int @@ BArith.min ik b >= precision ik) let shift_right ik a b = if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; if is_invalid_shift_operation ik a b then (bot (), {underflow=false; overflow=false}) + else if is_undefined_shift_operation ik a b + then + (top (), {underflow=false; overflow=false}) else norm ik @@ BArith.shift_right ik a (exclude_undefined_bitshifts ik b) @@ -1479,6 +1483,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if is_invalid_shift_operation ik a b then (bot (), {underflow=false; overflow=false}) + else if is_undefined_shift_operation ik a b + then + (top (), {underflow=false; overflow=false}) else norm ik @@ BArith.shift_left ik a (exclude_undefined_bitshifts ik b) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 8e6cf806c3..09711fc87e 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -493,11 +493,15 @@ struct | `B bf -> bf | `I is -> of_list is in + let string_of_param x = match x with + | `B bf -> I.show bf + | `I is -> Printf.sprintf "[%s]" (String.concat ", " @@ List.map string_of_int is) + in let bf_a, bf_b, expected = get_param a, get_param b, get_param expected in let result = (shift_op_bf bf_a bf_b) in let output_string = Printf.sprintf "test (%s) shift %s %s %s failed: was: %s but should be: %s" (string_of_ik ik) - (I.show bf_a) symb (I.show bf_b) + (string_of_param a) symb (string_of_param b) (I.show result) (I.show expected) in assert_bool output_string (I.equal result expected) @@ -543,6 +547,11 @@ struct ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list let bot = `B (I.bot ()) + let top = `B (I.top ()) + let double_max_int32 = Int.add (Int32.to_int @@ Int32.max_int) (Int32.to_int @@ Int32.max_int) + let max_int32 = Int32.to_int @@ Int32.max_int + let min_int32 = Int32.to_int @@ Int32.min_int + let minus_one32 = Int32.minus_one let test_shift_left = [ @@ -550,35 +559,53 @@ struct "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); - assert_shift_left ik (`I [1]) (`I [-1]) bot; + assert_shift_left ik (`I [1]) (`I [-1]) top; assert_shift_left ik bot (`I [1]) bot; assert_shift_left ik (`I [1]) bot bot; assert_shift_left ik bot bot bot; - assert_shift_left ik (`I [1]) (`I [over_precision ik]) bot; - assert_shift_left ik (`I [1]) (`I [over_precision ik; 0]) (`I [1]); - - assert_shift_left ik_uint (`I [1]) (`I [over_precision ik_uint]) bot; - assert_shift_left ik_uint (`I [4]) (`I [over_precision ik_uint; 0]) (`I [4]); + assert_shift_left ik (`I [1]) (`I [under_precision ik]) (`I [1073741824]); + (*assert_shift_left ik (`I [1]) (`I [precision ik; 0]) (`I [1]);*) (* TODO fails, intended? *) + assert_shift_left ik (`I [1]) (`I [precision ik]) top; + assert_shift_left ik (`I [1]) (`I [over_precision ik]) top; + + assert_shift_left ik (`I [-1]) (`I [under_precision ik]) (`I [-1073741824]); + (*assert_shift_left ik (`I [-1]) (`I [precision ik; 0]) (`I [-1]); *) (* TODO fails, intended? *) + assert_shift_left ik (`I [-1]) (`I [precision ik]) top; + assert_shift_left ik (`I [-1]) (`I [over_precision ik]) top; + + assert_shift_left ik_uint (`I [1]) (`I [under_precision ik_uint]) (`I [min_int32]); (* dirty written *) + assert_shift_left ik_uint (`I [1]) (`I [precision ik_uint; 0]) (`I [1]); + (* assert_shift_left ik_uint (`I [1]) (`I [precision ik_uint; 1]) (`I [2]);*) (* TODO fails, intended? *) + assert_shift_left ik_uint (`I [1]) (`I [precision ik_uint]) top; + assert_shift_left ik_uint (`I [1]) (`I [over_precision ik_uint]) top; ] let test_shift_right = - let double_max_int = Int.add Int.max_int Int.max_int in [ "property_test_shift_right" >::: test_shift_right; "shift_right_edge_cases" >:: fun _ -> assert_shift_right ik (`I [10]) (`I [1; 2]) (`I [10; 7; 5; 1]); - - assert_shift_right ik (`I [2]) (`I [-1]) bot; + + assert_shift_right ik (`I [2]) (`I [-1]) top; assert_shift_right ik bot (`I [1]) bot; assert_shift_right ik (`I [1]) bot bot; assert_shift_right ik bot bot bot; - assert_shift_right ik (`I [Int.min_int]) (`I [over_precision ik]) bot; - assert_shift_right ik (`I [Int.min_int]) (`I [over_precision ik; 0]) (`I [Int.min_int]); + assert_shift_right ik (`I [max_int32]) (`I [under_precision ik]) (`I [1]); + (*assert_shift_right ik (`I [4]) (`I [precision ik; 0]) (`I [4]);*) (* TODO fails, intended? *) + assert_shift_right ik (`I [max_int32]) (`I [precision ik]) top; + assert_shift_right ik (`I [max_int32]) (`I [over_precision ik]) top; + + assert_shift_right ik (`I [min_int32]) (`I [under_precision ik]) (`I [-2]); + (*assert_shift_right ik (`I [4]) (`I [precision ik; 0]) (`I [4]);*) (* TODO fails, intended? *) + assert_shift_right ik (`I [min_int32]) (`I [precision ik]) top; + assert_shift_right ik (`I [min_int32]) (`I [over_precision ik]) top; - assert_shift_right ik_uint (`I [double_max_int]) (`I [over_precision ik_uint]) bot; - assert_shift_right ik_uint (`I [double_max_int]) (`I [over_precision ik_uint; 0]) (`I [double_max_int]); + assert_shift_right ik_uint (`I [double_max_int32]) (`I [under_precision ik_uint]) (`I [1]); + assert_shift_right ik_uint (`I [4]) (`I [precision ik_uint; 0]) (`I [4]); + assert_shift_right ik_uint (`I [double_max_int32]) (`I [precision ik_uint]) top; + assert_shift_right ik_uint (`I [double_max_int32]) (`I [over_precision ik_uint]) top; ] From c68252714f7ee32ea7897145b97e8937253ab64c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Fri, 13 Dec 2024 16:06:00 +0100 Subject: [PATCH 096/111] added pape rreferences and refined div --- src/cdomain/value/cdomains/intDomain.ml | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4ae2e76f8b..3172e8a0a1 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1135,6 +1135,20 @@ module InfixIntOps (Ints_t : IntOps.IntOps) = struct let (>>.) = fun a b -> a >>: b |: !:((Ints_t.one <<: b) -: Ints_t.one) end +(* + Operations in the abstract domain mostly based on + + "Abstract Domains for Bit-Level Machine Integer and Floating-point Operations" + of Antoine Miné + https://doi.org/10.29007/b63g + + and + + the bachelor thesis "Integer Abstract Domains" + of Tomáš Brukner + https://is.muni.cz/th/kasap/thesis.pdf +*) + (* Bitfield arithmetic, without any overflow handling etc. *) module BitfieldArith (Ints_t : IntOps.IntOps) = struct @@ -1572,7 +1586,9 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik (!z3, !o3) let div ?no_ov ik (z1, o1) (z2, o2) = - let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = z1 /: z2 in (!:tmp, tmp)) else top_of ik in + let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = o1 /: o2 in (!:tmp, tmp)) + else if BArith.is_const (z2, o2) && is_power_of_two o2 then (z1 >>: (Ints_t.to_int o2), o1 >>: (Ints_t.to_int o2)) + else top_of ik in norm ik res let rem ik x y = From 7a8b3ad2dc23d3d7b1f7007367fba48b89be1767 Mon Sep 17 00:00:00 2001 From: leon Date: Sun, 15 Dec 2024 14:40:20 +0100 Subject: [PATCH 097/111] added some more cases --- tests/unit/cdomains/intDomainTest.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 09711fc87e..773f78376b 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -558,6 +558,11 @@ struct "property_test_shift_left" >::: test_shift_left; "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); + assert_shift_left ik_uint (`I [1]) (`I [32]) (top); + assert_shift_left ik_uint (`I [1]) (`I [31]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [31]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [31; 0]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [-1]) top; assert_shift_left ik bot (`I [1]) bot; From 8cf71921cd3beaf10fb9e8572285503d6e9dabfa Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Mon, 16 Dec 2024 08:22:03 +0100 Subject: [PATCH 098/111] more tests and overflow bugs detected. comment out TODO fails to see --- src/cdomain/value/cdomains/intDomain.ml | 17 +-- tests/unit/cdomains/intDomainTest.ml | 150 ++++++++++++++---------- 2 files changed, 101 insertions(+), 66 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 3172e8a0a1..c2b044cb90 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1217,10 +1217,11 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct else let is_bit_unknown = not ((bits_unknown (z,o) &: Ints_t.one) =: Ints_t.zero) in let bit = o &: Ints_t.one in - let shifted_z, shifted_o = (z >>. 1, o >>: 1) in - if is_bit_unknown - then concretize (shifted_z, shifted_o) |> List.concat_map (fun c -> [c <<: 1; (c <<: 1) |: Ints_t.one]) - else concretize (shifted_z, shifted_o) |> List.map (fun c -> c <<: 1 |: bit) + concretize (z >>. 1, o >>: 1) |> + if is_bit_unknown then + List.concat_map (fun c -> [c <<: 1; (c <<: 1) |: Ints_t.one]) + else + List.map (fun c -> c <<: 1 |: bit) let concretize bf = List.map Ints_t.to_int (concretize bf) @@ -1473,13 +1474,15 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let precision ik = snd @@ Size.bits ik let exclude_undefined_bitshifts ik (z,o) = let mask = BArith.bitmask_up_to (Z.log2up @@ Z.of_int @@ precision ik) in - (z |: !:mask, o &: mask) (* TODO bug here! *) + (z |: !:mask, o &: mask) let is_invalid_shift_operation ik a b = BArith.is_invalid b || BArith.is_invalid a - let is_undefined_shift_operation ik a b = (isSigned ik && BArith.min ik b < Z.zero) - || (Z.to_int @@ BArith.min ik b >= precision ik) + let is_undefined_shift_operation ik a b = + let some_negatives = BArith.min ik b < Z.zero in + let geq_precision = Z.to_int @@ BArith.min ik b >= precision ik in + (isSigned ik) && (some_negatives || geq_precision) let shift_right ik a b = if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index 773f78376b..ae8dfe9640 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -259,6 +259,8 @@ struct let ik_char = Cil.IChar let ik_uchar = Cil.IUChar + let ik_lst = [ik; ik_uint; ik_char; ik_uchar] + let assert_equal x y = OUnit.assert_equal ~printer:I.show x y @@ -483,7 +485,7 @@ struct let over_precision ik = Int.succ @@ precision ik let under_precision ik = Int.pred @@ precision ik - let assert_shift shift ik a b expected = + let assert_shift ?(rev_cond=false) shift ik a b expected = let symb, shift_op_bf, shift_op_int = match shift with | `L -> "<<", I.shift_left ik, Int.shift_left | `R -> ">>", I.shift_right ik, Int.shift_right @@ -499,21 +501,22 @@ struct in let bf_a, bf_b, expected = get_param a, get_param b, get_param expected in let result = (shift_op_bf bf_a bf_b) in - let output_string = Printf.sprintf "test (%s) shift %s %s %s failed: was: %s but should be: %s" + let output_string = Printf.sprintf "test (%s) shift %s %s %s failed: was: %s but should%s be: %s" (string_of_ik ik) (string_of_param a) symb (string_of_param b) - (I.show result) (I.show expected) + (I.show result) (if rev_cond then " not" else "") (I.show expected) in - assert_bool output_string (I.equal result expected) + let assertion = I.equal result expected in + let assertion = if rev_cond then not assertion else assertion in + assert_bool output_string assertion - let assert_shift_left = assert_shift `L - let assert_shift_right = assert_shift `R + let assert_shift_left ?(rev_cond=false) = assert_shift ~rev_cond:rev_cond `L + let assert_shift_right ?(rev_cond=false) = assert_shift ~rev_cond:rev_cond `R - let gen_sized_set size_gen gen = (* TODO might reduce the size of the generated list *) + let gen_sized_set size_gen gen = let open QCheck2.Gen in map (List.sort_uniq Int.compare) (list_size size_gen gen) - (* Checks the property: (U_{a in gamma a_bf, b in gamma b_bf} a shift b) leq (a_bf shift b_bf) *) let test_shift ik name c_op a_op = let shift_test_printer (a,b) = Printf.sprintf "a: [%s] b: [%s]" (String.concat ", " (List.map string_of_int a)) @@ -540,50 +543,67 @@ struct let test_shift_left = List.fold_left (fun acc ik -> test_shift ik (Printf.sprintf "test_shift_left_ik_%s" (string_of_ik ik)) Int.shift_left I.shift_left :: acc - ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list + ) [] ik_lst |> QCheck_ounit.to_ounit2_test_list let test_shift_right = List.fold_left (fun acc ik -> test_shift ik (Printf.sprintf "test_shift_right_ik_%s" (string_of_ik ik)) Int.shift_right I.shift_right :: acc - ) [] [Cil.IChar; Cil.IUChar; Cil.IInt; Cil.IUInt] |> QCheck_ounit.to_ounit2_test_list + ) [] ik_lst |> QCheck_ounit.to_ounit2_test_list let bot = `B (I.bot ()) let top = `B (I.top ()) - let double_max_int32 = Int.add (Int32.to_int @@ Int32.max_int) (Int32.to_int @@ Int32.max_int) - let max_int32 = Int32.to_int @@ Int32.max_int - let min_int32 = Int32.to_int @@ Int32.min_int - let minus_one32 = Int32.minus_one + + let isSigned = GoblintCil.Cil.isSigned + let cast ik = IntDomain.Size.cast ik + let range = IntDomain.Size.range + let bits = IntDomain.Size.bits + + let max_of ik = Z.to_int @@ snd @@ range ik + let min_of ik = Z.to_int @@ fst @@ range ik + let highest_bit_set ?(is_neg=false) ik = + let pos = Int.pred @@ snd @@ bits ik in + (if isSigned ik then if is_neg + then cast ik @@ Z.of_int @@ Int.neg @@ Int.shift_left 1 pos + else cast ik @@ Z.of_int @@ Int.pred @@ Int.shift_left 1 pos + else + cast ik @@ Z.of_int @@ Int.shift_left 1 pos) |> Z.to_int let test_shift_left = [ "property_test_shift_left" >::: test_shift_left; "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); - assert_shift_left ik_uint (`I [1]) (`I [32]) (top); - assert_shift_left ik_uint (`I [1]) (`I [31]) (`I [2147483648]); - assert_shift_left ik (`I [1]) (`I [31]) (`I [2147483648]); - assert_shift_left ik (`I [1]) (`I [31; 0]) (`I [2147483648]); - - - assert_shift_left ik (`I [1]) (`I [-1]) top; - assert_shift_left ik bot (`I [1]) bot; - assert_shift_left ik (`I [1]) bot bot; - assert_shift_left ik bot bot bot; - - assert_shift_left ik (`I [1]) (`I [under_precision ik]) (`I [1073741824]); - (*assert_shift_left ik (`I [1]) (`I [precision ik; 0]) (`I [1]);*) (* TODO fails, intended? *) - assert_shift_left ik (`I [1]) (`I [precision ik]) top; - assert_shift_left ik (`I [1]) (`I [over_precision ik]) top; - - assert_shift_left ik (`I [-1]) (`I [under_precision ik]) (`I [-1073741824]); - (*assert_shift_left ik (`I [-1]) (`I [precision ik; 0]) (`I [-1]); *) (* TODO fails, intended? *) - assert_shift_left ik (`I [-1]) (`I [precision ik]) top; - assert_shift_left ik (`I [-1]) (`I [over_precision ik]) top; - - assert_shift_left ik_uint (`I [1]) (`I [under_precision ik_uint]) (`I [min_int32]); (* dirty written *) - assert_shift_left ik_uint (`I [1]) (`I [precision ik_uint; 0]) (`I [1]); - (* assert_shift_left ik_uint (`I [1]) (`I [precision ik_uint; 1]) (`I [2]);*) (* TODO fails, intended? *) - assert_shift_left ik_uint (`I [1]) (`I [precision ik_uint]) top; - assert_shift_left ik_uint (`I [1]) (`I [over_precision ik_uint]) top; + + List.iter (fun ik -> + assert_shift_left ik bot (`I [1]) bot; + assert_shift_left ik (`I [1]) bot bot; + assert_shift_left ik bot bot bot; + + if isSigned ik + then ( + assert_shift_left ik (`I [0]) top top; + + assert_shift_left ik (`I [1]) (`I [-1]) top; (* Negative shifts are undefined behavior *) + assert_shift_left ik (`I [-1]) top top; + assert_shift_left ~rev_cond:true ik (`I [1]) top top; (* TODO fails *) + + assert_shift_left ~rev_cond:true ik (`I [1]) (`I [under_precision ik]) top; + assert_shift_left ik (`I [1]) (`I [precision ik]) top; + assert_shift_left ik (`I [1]) (`I [over_precision ik]) top; + + assert_shift_left ik (`I [-1]) (`I [under_precision ik]) (`I [highest_bit_set ~is_neg:true ik]); + assert_shift_left ik (`I [-1]) (`I [precision ik]) top; + assert_shift_left ik (`I [-1]) (`I [over_precision ik]) top; + ) else ( + (* See C11 N2310 at 6.5.7 *) + assert_shift_left ik (`I [0]) top (`I [0]); + + assert_shift_left ik_uint (`I [1]) (`I [under_precision ik]) (`I [highest_bit_set ik]); + assert_shift_left ik_uint (`I [1]) (`I [precision ik]) (`I [1]); (* TODO fails due to wrong overflow handling? *) + assert_shift_left ik_uint (`I [1]) (`I [over_precision ik]) (`I [2]); (* TODO fails due to wrong overflow handling? *) + ) + + ) ik_lst + ] let test_shift_right = @@ -591,26 +611,38 @@ struct "property_test_shift_right" >::: test_shift_right; "shift_right_edge_cases" >:: fun _ -> assert_shift_right ik (`I [10]) (`I [1; 2]) (`I [10; 7; 5; 1]); + + List.iter (fun ik -> + assert_shift_right ik bot (`I [1]) bot; + assert_shift_right ik (`I [1]) bot bot; + assert_shift_right ik bot bot bot; + + if isSigned ik + then ( + assert_shift_right ik (`I [0]) top top; + + assert_shift_right ik (`I [2]) (`I [-1]) top; (* Negative shifts are undefined behavior *) + assert_shift_right ik (`I [min_of ik]) top top; + assert_shift_right ~rev_cond:true ik (`I [max_of ik]) top top; (* TODO fails *) + + assert_shift_right ik (`I [max_of ik]) (`I [under_precision ik]) (`I [1]); + assert_shift_right ik (`I [max_of ik]) (`I [precision ik]) top; + assert_shift_right ik (`I [max_of ik]) (`I [over_precision ik]) top; + + assert_shift_right ik (`I [min_of ik]) (`I [under_precision ik]) (`I [-2]); + assert_shift_right ik (`I [min_of ik]) (`I [precision ik]) top; + assert_shift_right ik (`I [min_of ik]) (`I [over_precision ik]) top; + ) else ( + (* See C11 N2310 at 6.5.7 *) + assert_shift_right ik (`I [0]) top (`I [0]); + + assert_shift_right ik (`I [max_of ik]) (`I [under_precision ik]) (`I [1]); + assert_shift_right ik (`I [max_of ik]) (`I [precision ik]) (`I [0]); (* TODO fails due to wrong overflow handling? *) + assert_shift_right ik (`I [max_of ik]) (`I [over_precision ik]) (`I [0]); (* TODO fails due to wrong overflow handling? *) + ) + + ) ik_lst - assert_shift_right ik (`I [2]) (`I [-1]) top; - assert_shift_right ik bot (`I [1]) bot; - assert_shift_right ik (`I [1]) bot bot; - assert_shift_right ik bot bot bot; - - assert_shift_right ik (`I [max_int32]) (`I [under_precision ik]) (`I [1]); - (*assert_shift_right ik (`I [4]) (`I [precision ik; 0]) (`I [4]);*) (* TODO fails, intended? *) - assert_shift_right ik (`I [max_int32]) (`I [precision ik]) top; - assert_shift_right ik (`I [max_int32]) (`I [over_precision ik]) top; - - assert_shift_right ik (`I [min_int32]) (`I [under_precision ik]) (`I [-2]); - (*assert_shift_right ik (`I [4]) (`I [precision ik; 0]) (`I [4]);*) (* TODO fails, intended? *) - assert_shift_right ik (`I [min_int32]) (`I [precision ik]) top; - assert_shift_right ik (`I [min_int32]) (`I [over_precision ik]) top; - - assert_shift_right ik_uint (`I [double_max_int32]) (`I [under_precision ik_uint]) (`I [1]); - assert_shift_right ik_uint (`I [4]) (`I [precision ik_uint; 0]) (`I [4]); - assert_shift_right ik_uint (`I [double_max_int32]) (`I [precision ik_uint]) top; - assert_shift_right ik_uint (`I [double_max_int32]) (`I [over_precision ik_uint]) top; ] From 79a859a69adc8ec7130a0f2bb5f4af045db62c46 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Mon, 16 Dec 2024 16:49:25 +0100 Subject: [PATCH 099/111] bugfix: zero shifted by anything should be zero --- src/cdomain/value/cdomains/intDomain.ml | 4 +-- tests/unit/cdomains/intDomainTest.ml | 34 ++++++++++++------------- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c2b044cb90..80d570f341 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1481,8 +1481,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let is_undefined_shift_operation ik a b = let some_negatives = BArith.min ik b < Z.zero in - let geq_precision = Z.to_int @@ BArith.min ik b >= precision ik in - (isSigned ik) && (some_negatives || geq_precision) + let b_is_geq_precision = Z.to_int @@ BArith.min ik b >= precision ik in + (isSigned ik) && (some_negatives || b_is_geq_precision) && not (a = BArith.zero) let shift_right ik a b = if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index ae8dfe9640..ca39a68478 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -258,8 +258,10 @@ struct let ik_uint = Cil.IUInt let ik_char = Cil.IChar let ik_uchar = Cil.IUChar + let ik_short = Cil.IShort + let ik_ushort = Cil.IUShort - let ik_lst = [ik; ik_uint; ik_char; ik_uchar] + let ik_lst = [ik_char; ik_uchar; ik_short; ik_ushort; ik; ik_uint;] let assert_equal x y = OUnit.assert_equal ~printer:I.show x y @@ -479,6 +481,8 @@ struct | Cil.IUInt -> "unsigned_int" | Cil.IChar -> "char" | Cil.IUChar -> "unsigned_char" + | Cil.IShort -> "short" + | Cil.IUShort -> "unsigned_short" | _ -> "undefined C primitive type" let precision ik = snd @@ IntDomain.Size.bits ik @@ -553,13 +557,11 @@ struct let top = `B (I.top ()) let isSigned = GoblintCil.Cil.isSigned - let cast ik = IntDomain.Size.cast ik - let range = IntDomain.Size.range - let bits = IntDomain.Size.bits - let max_of ik = Z.to_int @@ snd @@ range ik - let min_of ik = Z.to_int @@ fst @@ range ik + let max_of ik = Z.to_int @@ snd @@ IntDomain.Size.range ik + let min_of ik = Z.to_int @@ fst @@ IntDomain.Size.range ik let highest_bit_set ?(is_neg=false) ik = + let open IntDomain.Size in let pos = Int.pred @@ snd @@ bits ik in (if isSigned ik then if is_neg then cast ik @@ Z.of_int @@ Int.neg @@ Int.shift_left 1 pos @@ -578,13 +580,14 @@ struct assert_shift_left ik (`I [1]) bot bot; assert_shift_left ik bot bot bot; + assert_shift_left ik (`I [0]) top (`I [0]); + if isSigned ik then ( - assert_shift_left ik (`I [0]) top top; + (*assert_shift_left ~rev_cond:true ik (`I [1]) top top;*) (* TODO fails *) assert_shift_left ik (`I [1]) (`I [-1]) top; (* Negative shifts are undefined behavior *) assert_shift_left ik (`I [-1]) top top; - assert_shift_left ~rev_cond:true ik (`I [1]) top top; (* TODO fails *) assert_shift_left ~rev_cond:true ik (`I [1]) (`I [under_precision ik]) top; assert_shift_left ik (`I [1]) (`I [precision ik]) top; @@ -595,11 +598,9 @@ struct assert_shift_left ik (`I [-1]) (`I [over_precision ik]) top; ) else ( (* See C11 N2310 at 6.5.7 *) - assert_shift_left ik (`I [0]) top (`I [0]); - - assert_shift_left ik_uint (`I [1]) (`I [under_precision ik]) (`I [highest_bit_set ik]); - assert_shift_left ik_uint (`I [1]) (`I [precision ik]) (`I [1]); (* TODO fails due to wrong overflow handling? *) - assert_shift_left ik_uint (`I [1]) (`I [over_precision ik]) (`I [2]); (* TODO fails due to wrong overflow handling? *) + assert_shift_left ik (`I [1]) (`I [under_precision ik]) (`I [highest_bit_set ik]); + assert_shift_left ik (`I [1]) (`I [precision ik]) (`I [1]); + assert_shift_left ik (`I [1]) (`I [over_precision ik]) (`I [2]); ) ) ik_lst @@ -617,13 +618,14 @@ struct assert_shift_right ik (`I [1]) bot bot; assert_shift_right ik bot bot bot; + assert_shift_right ik (`I [0]) top (`I [0]); + if isSigned ik then ( - assert_shift_right ik (`I [0]) top top; + (*assert_shift_right ~rev_cond:true ik (`I [max_of ik]) top top;*) (* TODO fails *) assert_shift_right ik (`I [2]) (`I [-1]) top; (* Negative shifts are undefined behavior *) assert_shift_right ik (`I [min_of ik]) top top; - assert_shift_right ~rev_cond:true ik (`I [max_of ik]) top top; (* TODO fails *) assert_shift_right ik (`I [max_of ik]) (`I [under_precision ik]) (`I [1]); assert_shift_right ik (`I [max_of ik]) (`I [precision ik]) top; @@ -634,8 +636,6 @@ struct assert_shift_right ik (`I [min_of ik]) (`I [over_precision ik]) top; ) else ( (* See C11 N2310 at 6.5.7 *) - assert_shift_right ik (`I [0]) top (`I [0]); - assert_shift_right ik (`I [max_of ik]) (`I [under_precision ik]) (`I [1]); assert_shift_right ik (`I [max_of ik]) (`I [precision ik]) (`I [0]); (* TODO fails due to wrong overflow handling? *) assert_shift_right ik (`I [max_of ik]) (`I [over_precision ik]) (`I [0]); (* TODO fails due to wrong overflow handling? *) From f40fefbbc507db20a217a63ef2aa417b53427938 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 17 Dec 2024 10:44:10 +0100 Subject: [PATCH 100/111] refactored intDomain --- .../value/cdomains/int/bitfieldDomain.ml | 585 +++ .../value/cdomains/int/congruenceDomain.ml | 508 ++ .../value/cdomains/int/defExcDomain.ml | 547 ++ src/cdomain/value/cdomains/int/enumsDomain.ml | 378 ++ src/cdomain/value/cdomains/int/intDomTuple.ml | 560 ++ .../value/cdomains/int/intervalDomain.ml | 477 ++ .../value/cdomains/int/intervalSetDomain.ml | 567 ++ src/cdomain/value/cdomains/intDomain.ml | 4538 +---------------- src/cdomain/value/cdomains/intDomain.mli | 2 +- src/cdomain/value/cdomains/intDomain0.ml | 933 ++++ 10 files changed, 4565 insertions(+), 4530 deletions(-) create mode 100644 src/cdomain/value/cdomains/int/bitfieldDomain.ml create mode 100644 src/cdomain/value/cdomains/int/congruenceDomain.ml create mode 100644 src/cdomain/value/cdomains/int/defExcDomain.ml create mode 100644 src/cdomain/value/cdomains/int/enumsDomain.ml create mode 100644 src/cdomain/value/cdomains/int/intDomTuple.ml create mode 100644 src/cdomain/value/cdomains/int/intervalDomain.ml create mode 100644 src/cdomain/value/cdomains/int/intervalSetDomain.ml create mode 100644 src/cdomain/value/cdomains/intDomain0.ml diff --git a/src/cdomain/value/cdomains/int/bitfieldDomain.ml b/src/cdomain/value/cdomains/int/bitfieldDomain.ml new file mode 100644 index 0000000000..74c39b1624 --- /dev/null +++ b/src/cdomain/value/cdomains/int/bitfieldDomain.ml @@ -0,0 +1,585 @@ +open IntDomain0 +open GoblintCil + +module BitfieldInfixOps (Ints_t : IntOps.IntOps) = struct + let (&:) = Ints_t.logand + let (|:) = Ints_t.logor + let (^:) = Ints_t.logxor + let (!:) = Ints_t.lognot + let (<<:) = Ints_t.shift_left + let (>>:) = Ints_t.shift_right + let (<:) = fun a b -> Ints_t.compare a b < 0 + let (=:) = fun a b -> Ints_t.compare a b = 0 + let (>:) = fun a b -> Ints_t.compare a b > 0 + + let (+:) = Ints_t.add + let (-:) = Ints_t.sub + let ( *: ) = Ints_t.mul + let (/:) = Ints_t.div + let (%:) = Ints_t.rem + + let (>>.) = fun a b -> a >>: b |: !:((Ints_t.one <<: b) -: Ints_t.one) +end + +(* + Operations in the abstract domain mostly based on + + "Abstract Domains for Bit-Level Machine Integer and Floating-point Operations" + of Antoine Miné + https://doi.org/10.29007/b63g + + and + + the bachelor thesis "Integer Abstract Domains" + of Tomáš Brukner + https://is.muni.cz/th/kasap/thesis.pdf +*) + +(* Bitfield arithmetic, without any overflow handling etc. *) +module BitfieldArith (Ints_t : IntOps.IntOps) = struct + + include BitfieldInfixOps (Ints_t) + + let zero_mask = Ints_t.zero + let one_mask = !:zero_mask + + let of_int x = (!:x, x) + + let join (z1,o1) (z2,o2) = (z1 |: z2, o1 |: o2) + let meet (z1,o1) (z2,o2) = (z1 &: z2, o1 &: o2) + + let one = of_int Ints_t.one + let zero = of_int Ints_t.zero + let top_bool = join one zero + + let bits_known (z,o) = z ^: o + let bits_unknown (z,o) = z &: o + let bits_set bf = (snd bf) &: (bits_known bf) + let bits_invalid (z,o) = !:(z |: o) + + let is_const (z,o) = (z ^: o) =: one_mask + + let is_invalid (z,o) = + not (!:(z |: o) = Ints_t.zero) + + let nabla x y= if x =: (x |: y) then x else one_mask + + let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) + + let lognot (z,o) = (o,z) + + let logxor (z1,o1) (z2,o2) = ((z1 &: z2) |: (o1 &: o2), + (z1 &: o2) |: (o1 &: z2)) + + let logand (z1,o1) (z2,o2) = (z1 |: z2, o1 &: o2) + + let logor (z1,o1) (z2,o2) = (z1 &: z2, o1 |: o2) + + let bitmask_up_to pos = + let top_bit = Ints_t.one <<: pos in + if top_bit =: Ints_t.zero + then Ints_t.zero + else + Ints_t.sub top_bit Ints_t.one + + let get_bit bf pos = Ints_t.one &: (bf >>: pos) + + let min ik (z,o) = + let signBit = Ints_t.one <<: ((Size.bit ik) - 1) in + let signMask = !: (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = signBit &: o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.to_bigint(signMask |: (!: z)) + else Ints_t.to_bigint(!: z) + + let max ik (z,o) = + let signBit = Ints_t.one <<: ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = signBit &: z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.to_bigint(signMask &: o) + else Ints_t.to_bigint o + + let rec concretize (z,o) = + if is_const (z,o) then [o] + else + let is_bit_unknown = not ((bits_unknown (z,o) &: Ints_t.one) =: Ints_t.zero) in + let bit = o &: Ints_t.one in + let shifted_z, shifted_o = (z >>. 1, o >>: 1) in + if is_bit_unknown + then concretize (shifted_z, shifted_o) |> List.concat_map (fun c -> [c <<: 1; (c <<: 1) |: Ints_t.one]) + else concretize (shifted_z, shifted_o) |> List.map (fun c -> c <<: 1 |: bit) + + let concretize bf = List.map Ints_t.to_int (concretize bf) + + let shift_right ik (z,o) c = + let sign_mask = !:(bitmask_up_to (Size.bit ik - c)) in + if isSigned ik && o <: Ints_t.zero then + (z >>: c, (o >>: c) |: sign_mask) + else + ((z >>: c) |: sign_mask, o >>: c) + + let shift_right ik (z1, o1) (z2, o2) = + if is_const (z2, o2) + then + shift_right ik (z1, o1) (Ints_t.to_int o2) + else + let shift_counts = concretize (z2, o2) in + List.fold_left (fun acc c -> + let next = shift_right ik (z1, o1) c in join acc next + ) (zero_mask, zero_mask) shift_counts + + let shift_left _ (z,o) c = + let zero_mask = bitmask_up_to c in + ((z <<: c) |: zero_mask, o <<: c) + + let shift_left ik (z1, o1) (z2, o2) = + if is_const (z2, o2) + then + shift_left ik (z1, o1) (Ints_t.to_int o2) + else + let shift_counts = concretize (z2, o2) in + List.fold_left (fun acc c -> + let next = shift_left ik (z1, o1) c in join acc next + ) (zero_mask, zero_mask) shift_counts + +end + +module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct + + include BitfieldInfixOps (Ints_t) + + let name () = "bitfield" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] + + module BArith = BitfieldArith (Ints_t) + + let top () = (BArith.one_mask, BArith.one_mask) + let bot () = (BArith.zero_mask, BArith.zero_mask) + let top_of ik = + if isSigned ik then top () + else (BArith.one_mask, Ints_t.of_bigint (snd (Size.range ik))) + let bot_of ik = bot () + + let to_pretty_bits (z,o) = + let known_bitmask = ref (BArith.bits_known (z,o)) in + let invalid_bitmask = ref (BArith.bits_invalid (z,o)) in + let o_mask = ref o in + let z_mask = ref z in + + let rec to_pretty_bits' acc = + let current_bit_known = (!known_bitmask &: Ints_t.one) = Ints_t.one in + let current_bit_impossible = (!invalid_bitmask &: Ints_t.one) = Ints_t.one in + + let bit_value = !o_mask &: Ints_t.one in + let bit = + if current_bit_impossible then "⊥" + else if not current_bit_known then "⊤" + else Ints_t.to_string bit_value + in + + if (!o_mask = Ints_t.of_int (-1) || !o_mask = Ints_t.zero ) && (!z_mask = Ints_t.of_int (-1) || !z_mask = Ints_t.zero) then + let prefix = bit ^ "..." ^ bit in + prefix ^ acc + else + (known_bitmask := !known_bitmask >>: 1; + invalid_bitmask := !invalid_bitmask >>: 1; + o_mask := !o_mask >>: 1; + z_mask := !z_mask >>: 1; + to_pretty_bits' (bit ^ acc)) + in + "0b" ^ to_pretty_bits' "" + + let show t = + if t = bot () then "bot" else + if t = top () then "top" else + let (z,o) = t in + Format.sprintf "{%s, (zs:%s, os:%s)}" (to_pretty_bits t) (Ints_t.to_string z) (Ints_t.to_string o) + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let range ik bf = (BArith.min ik bf, BArith.max ik bf) + + let maximal (z,o) = + if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some o + else None + + let minimal (z,o) = + if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some (!:z) + else None + + let wrap ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + if isSigned ik then + let newz = (z &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit z (Size.bit ik - 1))) in + let newo = (o &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit o (Size.bit ik - 1))) in + (newz,newo) + else + let newz = z |: !:(Ints_t.of_bigint max_ik) in + let newo = o &: (Ints_t.of_bigint max_ik) in + (newz,newo) + + let norm ?(suppress_ovwarn=false) ik (z,o) = + if BArith.is_invalid (z,o) then + (bot (), {underflow=false; overflow=false}) + else + let (min_ik, max_ik) = Size.range ik in + let isPos = z < Ints_t.zero in + let isNeg = o < Ints_t.zero in + let underflow = if isSigned ik then (((Ints_t.of_bigint min_ik) &: z) <> Ints_t.zero) && isNeg else isNeg in + + let overflow = (((!: (Ints_t.of_bigint max_ik)) &: o) <> Ints_t.zero) && isPos in + let new_bitfield = wrap ik (z,o) + in + let overflow_info = if suppress_ovwarn then {underflow=false; overflow=false} else {underflow=underflow; overflow=overflow} in + if not (underflow || overflow) then + ((z,o), overflow_info) + else if should_wrap ik then + (new_bitfield, overflow_info) + else if should_ignore_overflow ik then + (M.warn ~category:M.Category.Integer.overflow "Bitfield: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Top"; + (* (bot (), overflow_info)) *) + (top_of ik, overflow_info)) + else + (top (), overflow_info) + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t + + let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst + + let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst + + let leq (x:t) (y:t) = (BArith.join x y) = y + + let widen ik x y = (norm ik @@ BArith.widen x y) |> fst + + let narrow ik x y = meet ik x y + + let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) + + let to_int (z,o) = if is_bot (z,o) then None else + if BArith.is_const (z,o) then Some o + else None + + let equal_to i bf = + if BArith.of_int i = bf then `Eq + else if leq (BArith.of_int i) bf then `Top + else `Neq + + (* Conversions *) + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + let (min_ik, max_ik) = Size.range ik in + let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in + let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in + + let rec analyze_bits pos (acc_z, acc_o) = + if pos < 0 then (acc_z, acc_o) + else + let position = Ints_t.shift_left Ints_t.one pos in + let mask = Ints_t.sub position Ints_t.one in + let remainder = Ints_t.logand startv mask in + + let without_remainder = Ints_t.sub startv remainder in + let bigger_number = Ints_t.add without_remainder position in + + let bit_status = + if Ints_t.compare bigger_number endv <= 0 then + `top + else + if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then + `one + else + `zero + in + + let new_acc = + match bit_status with + | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) + | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) + | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) + + in + analyze_bits (pos - 1) new_acc + in + let result = analyze_bits (Size.bit ik - 1) (bot()) in + let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) + in (wrap ik casted, {underflow=false; overflow=false}) + + let of_bool _ik = function true -> BArith.one | false -> BArith.zero + + let to_bool d = + if not (leq BArith.zero d) then Some true + else if d = BArith.zero then Some false + else None + + let of_bitfield ik x = norm ik x |> fst + + let to_bitfield ik x = norm ik x |> fst + + let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) + + let of_congruence ik (c,m) = + if m = Ints_t.zero then of_int ik c |> fst + else if is_power_of_two m then + let mod_mask = m -: Ints_t.one in + let z = !: c in + let o = !:mod_mask |: c in + norm ik (z,o) |> fst + else top_of ik + + (* Logic *) + + let log1 f ik i1 = match to_bool i1 with + | None -> top_of ik + | Some x -> of_bool ik (f x) + + let log2 f ~annihilator ik i1 i2 = match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log2 (||) ~annihilator:true + + let c_logand = log2 (&&) ~annihilator:false + + let c_lognot ik i1 = log1 not ik i1 + + + (* Bitwise *) + + let logxor ik i1 i2 = BArith.logxor i1 i2 |> norm ik |> fst + + let logand ik i1 i2 = BArith.logand i1 i2 |> norm ik |> fst + + let logor ik i1 i2 = BArith.logor i1 i2 |> norm ik |> fst + + let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst + + let precision ik = snd @@ Size.bits ik + let exclude_undefined_bitshifts ik (z,o) = + let mask = BArith.bitmask_up_to (Z.log2up @@ Z.of_int @@ precision ik) in + (z |: !:mask, o &: mask) (* TODO bug here! *) + + let is_invalid_shift_operation ik a b = BArith.is_invalid b + || BArith.is_invalid a + + let is_undefined_shift_operation ik a b = (isSigned ik && BArith.min ik b < Z.zero) + || (Z.to_int @@ BArith.min ik b >= precision ik) + + let shift_right ik a b = + if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; + if is_invalid_shift_operation ik a b + then + (bot (), {underflow=false; overflow=false}) + else if is_undefined_shift_operation ik a b + then + (top (), {underflow=false; overflow=false}) + else + norm ik @@ BArith.shift_right ik a (exclude_undefined_bitshifts ik b) + + let shift_left ik a b = + if M.tracing then M.trace "bitfield" "%a << %a" pretty a pretty b; + if is_invalid_shift_operation ik a b + then + (bot (), {underflow=false; overflow=false}) + else if is_undefined_shift_operation ik a b + then + (top (), {underflow=false; overflow=false}) + else + norm ik @@ BArith.shift_left ik a (exclude_undefined_bitshifts ik b) + + (* Arith *) + + (* + add, sub and mul based on the paper + "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" + of Vishwanathan et al. + https://doi.org/10.1109/CGO53902.2022.9741267 + *) + + let add_paper pv pm qv qm = + let sv = pv +: qv in + let sm = pm +: qm in + let sigma = sv +: sm in + let chi = sigma ^: sv in + let mu = pm |: qm |: chi in + let rv = sv &: !:mu in + let rm = mu in + (rv, rm) + + let add ?no_ov ik (z1, o1) (z2, o2) = + let pv = o1 &: !:z1 in + let pm = o1 &: z1 in + let qv = o2 &: !:z2 in + let qm = o2 &: z2 in + let (rv, rm) = add_paper pv pm qv qm in + let o3 = rv |: rm in + let z3 = !:rv |: rm in + norm ik (z3,o3) + + let sub ?no_ov ik (z1, o1) (z2, o2) = + let pv = o1 &: !:z1 in + let pm = o1 &: z1 in + let qv = o2 &: !:z2 in + let qm = o2 &: z2 in + let dv = pv -: qv in + let alpha = dv +: pm in + let beta = dv -: qm in + let chi = alpha ^: beta in + let mu = pm |: qm |: chi in + let rv = dv &: !:mu in + let rm = mu in + let o3 = rv |: rm in + let z3 = !:rv |: rm in + norm ik (z3, o3) + + let neg ?no_ov ik x = + M.trace "bitfield" "neg"; + sub ?no_ov ik BArith.zero x + + let mul ?no_ov ik (z1, o1) (z2, o2) = + let pm = ref (z1 &: o1) in + let pv = ref (o1 &: !:z1) in + let qm = ref (z2 &: o2) in + let qv = ref (o2 &: !:z2) in + let accv = ref BArith.zero_mask in + let accm = ref BArith.zero_mask in + let size = if isSigned ik then Size.bit ik - 1 else Size.bit ik in + let bitmask = Ints_t.of_bigint (fst (Size.range ik)) in + let signBitUndef1 = z1 &: o1 &: bitmask in + let signBitUndef2 = z2 &: o2 &: bitmask in + let signBitUndef = signBitUndef1 |: signBitUndef2 in + let signBitDefO = (o1 ^: o2) &: bitmask in + let signBitDefZ = !:(o1 ^: o2) &: bitmask in + for _ = size downto 0 do + (if !pm &: Ints_t.one == Ints_t.one then + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (!qv |: !qm)) + else if !pv &: Ints_t.one == Ints_t.one then + accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); + + pv := !pv >>: 1; + pm := !pm >>: 1; + qv := !qv <<: 1; + qm := !qm <<: 1; + done; + let (rv, rm) = add_paper !accv Ints_t.zero Ints_t.zero !accm in + let o3 = ref(rv |: rm) in + let z3 = ref(!:rv |: rm) in + if isSigned ik then z3 := signBitUndef |: signBitDefZ |: !z3; + if isSigned ik then o3 := signBitUndef |: signBitDefO |: !o3; + norm ik (!z3, !o3) + + let div ?no_ov ik (z1, o1) (z2, o2) = + let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = o1 /: o2 in (!:tmp, tmp)) + else if BArith.is_const (z2, o2) && is_power_of_two o2 then (z1 >>: (Ints_t.to_int o2), o1 >>: (Ints_t.to_int o2)) + else top_of ik in + norm ik res + + let rem ik x y = + if BArith.is_const x && BArith.is_const y then ( + let def_x = Option.get (to_int x) in + let def_y = Option.get (to_int y) in + fst (of_int ik (Ints_t.rem def_x def_y)) + ) + else if BArith.is_const y && is_power_of_two (snd y) then ( + let mask = Ints_t.sub (snd y) Ints_t.one in + let newz = Ints_t.logor (fst x) (Ints_t.lognot mask) in + let newo = Ints_t.logand (snd x) mask in + norm ik (newz, newo) |> fst + ) + else top_of ik + + let eq ik x y = + if (BArith.max ik x) <= (BArith.min ik y) && (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true + else if (BArith.min ik x) > (BArith.max ik y) || (BArith.max ik x) < (BArith.min ik y) then of_bool ik false + else BArith.top_bool + + let ne ik x y = match eq ik x y with + | t when t = of_bool ik true -> of_bool ik false + | t when t = of_bool ik false -> of_bool ik true + | _ -> BArith.top_bool + + let le ik x y = + if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false + else BArith.top_bool + + let ge ik x y = le ik y x + + let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true + else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false + else BArith.top_bool + + let gt ik x y = lt ik y x + + (* Invariant *) + + let invariant_ikind e ik (z,o) = + let range = range ik (z,o) in + IntInvariant.of_interval e ik range + + let starting ?(suppress_ovwarn=false) ik n = + let (min_ik, max_ik) = Size.range ik in + of_interval ~suppress_ovwarn ik (n, Ints_t.of_bigint max_ik) + + let ending ?(suppress_ovwarn=false) ik n = + let (min_ik, max_ik) = Size.range ik in + of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) + + (* Refinements *) + + let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = + match bf, cong with + | (z,o), Some (c, m) when m = Ints_t.zero -> norm ik (!: c, c) |> fst + | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> + let congruenceMask = !:m in + let newz = (!:congruenceMask &: z) |: (congruenceMask &: !:c) in + let newo = (!:congruenceMask &: o) |: (congruenceMask &: c) in + norm ik (newz, newo) |> fst + | _ -> norm ik bf |> fst + + let refine_with_interval ik t itv = + match itv with + | None -> norm ik t |> fst + | Some (l, u) -> meet ik t (of_interval ik (l, u) |> fst) + + let refine_with_bitfield ik x y = meet ik x y + + let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst + + let refine_with_incl_list ik t (incl : (int_t list) option) : t = + let joined =match incl with + | None -> top_of ik + | Some ls -> + List.fold_left (fun acc i -> BArith.join acc (BArith.of_int i)) (bot_of ik) ls + in + meet ik t joined + + + (* Unit Tests *) + + let arbitrary ik = + let open QCheck.Iter in + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink (z, o) = + (GobQCheck.shrink pair_arb (z, o) + >|= (fun (new_z, new_o) -> + (* Randomly flip bits to be opposite *) + let random_mask = Ints_t.of_int64 (Random.int64 (Int64.of_int (Size.bits ik |> snd))) in + let unsure_bitmask= new_z &: new_o in + let canceled_bits= unsure_bitmask &: random_mask in + let flipped_z = new_z |: canceled_bits in + let flipped_o = new_o &: !:canceled_bits in + norm ik (flipped_z, flipped_o) |> fst + )) + in + QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (i1,i2) |> fst ) pair_arb) + + let project ik p t = t + +end + +module Bitfield = BitfieldFunctor (IntOps.BigIntOps) \ No newline at end of file diff --git a/src/cdomain/value/cdomains/int/congruenceDomain.ml b/src/cdomain/value/cdomains/int/congruenceDomain.ml new file mode 100644 index 0000000000..964485acee --- /dev/null +++ b/src/cdomain/value/cdomains/int/congruenceDomain.ml @@ -0,0 +1,508 @@ +open IntDomain0 +open GoblintCil + + +module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = +struct + let name () = "congruences" + type int_t = Z.t + + (* represents congruence class of c mod m, None is bot *) + type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] + + let ( *: ) = Z.mul + let (+:) = Z.add + let (-:) = Z.sub + let (%:) = Z.rem + let (/:) = Z.div + let (=:) = Z.equal + let (<:) x y = Z.compare x y < 0 + let (>:) x y = Z.compare x y > 0 + let (<=:) x y = Z.compare x y <= 0 + let (>=:) x y = Z.compare x y >= 0 + (* a divides b *) + let ( |: ) a b = + if a =: Z.zero then false else (b %: a) =: Z.zero + + let normalize ik x = + match x with + | None -> None + | Some (c, m) -> + if m =: Z.zero then + if should_wrap ik then + Some (Size.cast ik c, m) + else + Some (c, m) + else + let m' = Z.abs m in + let c' = c %: m' in + if c' <: Z.zero then + Some (c' +: m', m') + else + Some (c' %: m', m') + + let range ik = Size.range ik + + let top () = Some (Z.zero, Z.one) + let top_of ik = Some (Z.zero, Z.one) + let bot () = None + let bot_of ik = bot () + + let show = function ik -> match ik with + | None -> "⟂" + | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c + | Some (c, m) -> + let a = if c =: Z.zero then "" else Z.to_string c in + let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in + let c = if a = "" || b = "" then "" else "+" in + a^c^b + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let is_top x = x = top () + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq + | Some (a, b) -> if i %: b =: a then `Top else `Neq + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero + | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 + (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 + Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) + + let leq x y = + let res = leq x y in + if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; + res + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (c1,m1), Some (c2,m2) -> + let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in + normalize ik (Some (c1, m3)) + + let join ik (x:t) y = + let res = join ik x y in + if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; + res + + + let meet ik x y = + (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) + let congruence_series a c m = + let rec next a1 c1 a2 c2 = + if a2 |: a1 then (a2, c2) + else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) + in next m Z.zero a c + in + let simple_case i c m = + if m |: (i -: c) + then Some (i, Z.zero) else None + in + match x, y with + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 + | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 + | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> + let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in + normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) + | _ -> None + + let meet ik x y = + let res = meet ik x y in + if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; + res + + let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None + let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) + let zero = Some (Z.zero, Z.zero) + let one = Some (Z.one, Z.zero) + let top_bool = top() + + let of_bool _ik = function true -> one | false -> zero + + let to_bool (a: t) = match a with + | None -> None + | x when equal zero x -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = top() + + let ending = starting + + let of_congruence ik (c,m) = normalize ik @@ Some(c,m) + + let to_bitfield ik x = + let is_power_of_two x = (Z.logand x (x -: Z.one) = Z.zero) in + match x with None -> (Z.zero, Z.zero) | Some (c,m) -> + if m = Z.zero then (Z.lognot c, c) + else if is_power_of_two m then + let mod_mask = m -: Z.one in + let z = Z.lognot c in + let o = Z.logor (Z.lognot mod_mask) c in + (z,o) + else (Z.lognot Z.zero, Z.lognot Z.zero) + + let maximal t = match t with + | Some (x, y) when y =: Z.zero -> Some x + | _ -> None + + let minimal t = match t with + | Some (x,y) when y =: Z.zero -> Some x + | _ -> None + + (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) + let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = + match x with + | None -> None + | Some (c, m) when m =: Z.zero -> + let c' = Size.cast t c in + (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) + (* We go with GCC behavior here: *) + (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) + (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) + (* Clang behaves the same but they never document that anywhere *) + Some (c', m) + | _ -> + let (min_t, max_t) = range t in + let p ikorg = + let (min_ikorg, max_ikorg) = range ikorg in + ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) + in + match torg with + | Some (Cil.TInt (ikorg, _)) when p ikorg -> + if M.tracing then M.trace "cong-cast" "some case"; + x + | _ -> top () + + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = + let pretty_bool _ x = Pretty.text (string_of_bool x) in + let res = cast_to ?torg ?no_ov t x in + if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; + res + + let widen = join + + let widen ik x y = + let res = widen ik x y in + if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; + res + + let narrow = meet + + let log f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) + let c_logand = log (&&) + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let shift_right _ _ _ = top() + + let shift_right ik x y = + let res = shift_right ik x y in + if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; + res + + let shift_left ik x y = + (* Naive primality test *) + (* let is_prime n = + let n = Z.abs n in + let rec is_prime' d = + (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) + in + not (n =: Z.one) && is_prime' (Z.of_int 2) + in *) + match x, y with + | None, None -> None + | None, _ + | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik + | Some (c, m), Some (c', m') -> + let (_, max_ik) = range ik in + if m =: Z.zero && m' =: Z.zero then + normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) + else + let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) + (* TODO: commented out because fails test with _Bool *) + (* if is_prime (m' +: Z.one) then + normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) + else *) + normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) + + let shift_left ik x y = + let res = shift_left ik x y in + if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; + res + + (* Handle unsigned overflows. + From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. + The congruence modulo b may not persist on an overflow. *) + let handle_overflow ik (c, m) = + if m =: Z.zero then + normalize ik (Some (c, m)) + else + (* Find largest m'=2^k (for some k) such that m is divisible by m' *) + let tz = Z.trailing_zeros m in + let m' = Z.shift_left Z.one tz in + + let max = (snd (Size.range ik)) +: Z.one in + if m' >=: max then + (* if m' >= 2 ^ {bitlength}, there is only one value in range *) + let c' = c %: max in + Some (c', Z.zero) + else + normalize ik (Some (c, m')) + + let mul ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) + in + match x, y with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) when no_ov -> + Some (no_ov_case (c1, m1) (c2, m2)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b ) + | _ -> top () + + let mul ?no_ov ik x y = + let res = mul ?no_ov ik x y in + if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; + res + + let neg ?(no_ov=false) ik x = + match x with + | None -> bot() + | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x + + let add ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 +: c2, Z.gcd m1 m2 + in + match (x, y) with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some a, Some b when no_ov -> + normalize ik (Some (no_ov_case a b)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b) + | _ -> top () + + + let add ?no_ov ik x y = + let res = add ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "add : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) + + + let sub ?no_ov ik x y = + let res = sub ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let lognot ik x = match x with + | None -> None + | Some (c, m) -> + if (Cil.isSigned ik) then + sub ik (neg ik x) one + else + let (_, max_ik) = range ik in + Some (Z.sub max_ik c, m) + + (** The implementation of the bit operations could be improved based on the master’s thesis + 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. + see: http://www.es.mdh.se/pdf_publications/948.pdf *) + let bit2 f ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) + else top () + + let logor ik x y = bit2 Z.logor ik x y + + let logand ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then + (* both arguments constant *) + Some (Z.logand c c', Z.zero) + else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then + (* x & 1 and x == c (mod 2*z) *) + (* Value is equal to LSB of c *) + Some (Z.logand c c', Z.zero) + else + top () + + let logxor ik x y = bit2 Z.logxor ik x y + + let rem ik x y = + match x, y with + | None, None -> bot() + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some(c2, m2) -> + if m2 =: Z.zero then + if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then + Some (c1 %: c2, Z.zero) + else + normalize ik (Some (c1, (Z.gcd m1 c2))) + else + normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) + + let rem ik x y = let res = rem ik x y in + if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; + res + + let div ?(no_ov=false) ik x y = + match x,y with + | None, None -> bot () + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, x when leq zero x -> top () + | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () + | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) + | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) + | _, _ -> top () + + + let div ?no_ov ik x y = + let res = div ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty + res ; + res + + let ne ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) + | x, y -> if meet ik x y = None then of_bool ik true else top_bool + + let eq ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) + | x, y -> if meet ik x y <> None then top_bool else of_bool ik false + + let comparison ik op x y = match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) -> + if m1 =: Z.zero && m2 =: Z.zero then + if op c1 c2 then of_bool ik true else of_bool ik false + else + top_bool + + let ge ik x y = comparison ik (>=:) x y + + let ge ik x y = + let res = ge ik x y in + if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let le ik x y = comparison ik (<=:) x y + + let le ik x y = + let res = le ik x y in + if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let gt ik x y = comparison ik (>:) x y + + + let gt ik x y = + let res = gt ik x y in + if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; + res + + let lt ik x y = comparison ik (<:) x y + + let lt ik x y = + let res = lt ik x y in + if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; + res + + let invariant_ikind e ik x = + match x with + | x when is_top x -> Invariant.top () + | Some (c, m) when m =: Z.zero -> + IntInvariant.of_int e ik c + | Some (c, m) -> + let open Cil in + let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in + Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) + | None -> Invariant.none + + let arbitrary ik = + let open QCheck in + let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in + let cong_arb = pair int_arb int_arb in + let of_pair ik p = normalize ik (Some p) in + let to_pair = Option.get in + set_print show (map ~rev:to_pair (of_pair ik) cong_arb) + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =: Z.zero then + if c <: x || c >: y then None else Some (c, Z.zero) + else + let rcx = x +: ((c -: x) %: Z.abs m) in + let lcy = y -: ((y -: c) %: Z.abs m) in + if rcx >: lcy then None + else if rcx =: lcy then Some (rcx, Z.zero) + else cong + | _ -> None + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = + let pretty_intv _ i = + match i with + | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u + | _ -> Pretty.text ("Display Error") in + let refn = refine_with_interval ik cong intv in + if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; + refn + + let refine_with_congruence ik a b = meet ik a b + let refine_with_bitfield ik a b = a + let refine_with_excl_list ik a b = a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end diff --git a/src/cdomain/value/cdomains/int/defExcDomain.ml b/src/cdomain/value/cdomains/int/defExcDomain.ml new file mode 100644 index 0000000000..1df48ba141 --- /dev/null +++ b/src/cdomain/value/cdomains/int/defExcDomain.ml @@ -0,0 +1,547 @@ +open IntDomain0 +open IntervalDomain +open GoblintCil + + +module BISet = struct + include SetDomain.Make (IntOps.BigIntOps) + let is_singleton s = cardinal s = 1 +end + +(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) +module Exclusion = +struct + module R = Interval32 + (* We use these types for the functions in this module to make the intended meaning more explicit *) + type t = Exc of BISet.t * Interval32.t + type inc = Inc of BISet.t [@@unboxed] + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) + + let cardinality_BISet s = + Z.of_int (BISet.cardinal s) + + let leq_excl_incl (Exc (xs, r)) (Inc ys) = + (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) + let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in + let card_b = cardinality_BISet ys in + if Z.compare lower_bound_cardinality_a card_b > 0 then + false + else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) + let min_a = min_of_range r in + let max_a = max_of_range r in + GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) + + let leq (Exc (xs, r)) (Exc (ys, s)) = + let min_a, max_a = min_of_range r, max_of_range r in + let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) + if not excluded_check + then false + else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) + if R.leq r s then true + else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) + then + let min_b, max_b = min_of_range s, max_of_range s in + let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) + if Z.compare min_a min_b < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) + else + true + in + let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) + if Z.compare max_b max_a < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) + else + true + in + leq1 && (leq2 ()) + else + false + end + end +end + +module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) +struct + module S = BISet + module R = Interval32 (* range for exclusion *) + + (* Ikind used for intervals representing the domain *) + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + + type t = [ + | `Excluded of S.t * R.t + | `Definite of Z.t + | `Bot + ] [@@deriving eq, ord, hash] + type int_t = Z.t + let name () = "def_exc" + + + let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) + let top () = `Excluded (S.empty (), top_range) + let bot () = `Bot + let top_of ik = `Excluded (S.empty (), size ik) + let bot_of ik = bot () + + let show x = + let short_size x = "("^R.show x^")" in + match x with + | `Bot -> "Error int" + | `Definite x -> Z.to_string x + (* Print the empty exclusion as if it was a distinct top element: *) + | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l + (* Prepend the exclusion sets with something: *) + | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let maximal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.max_of_range r) + | `Bot -> None + + let minimal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.min_of_range r) + | `Bot -> None + + let in_range r i = + if Z.compare i Z.zero < 0 then + let lowerb = Exclusion.min_of_range r in + Z.compare lowerb i <= 0 + else + let upperb = Exclusion.max_of_range r in + Z.compare i upperb <= 0 + + let is_top x = x = top () + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Definite x -> if i = x then `Eq else `Neq + | `Excluded (s,r) -> if S.mem i s then `Neq else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function + | `Excluded (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + `Excluded (s, r) + else if ik = IBool then (* downcast to bool *) + if S.mem Z.zero s then + `Definite Z.one + else + `Excluded (S.empty(), r') + else + (* downcast: may overflow *) + (* let s' = S.map (Size.cast ik) s in *) + (* We want to filter out all i in s' where (t)x with x in r could be i. *) + (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) + (* S.diff s' s, r' *) + (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) + `Excluded (S.empty (), r') + | `Definite x -> `Definite (Size.cast ik x) + | `Bot -> `Bot + + (* Wraps definite values and excluded values according to the ikind. + * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. + * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. + *) + let norm ik v = + match v with + | `Excluded (s, r) -> + let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in + (* If no overflow occurred, just return x *) + if not possibly_overflowed then ( + v + ) + (* Else, if an overflow might have occurred but we should just ignore it *) + else if should_ignore_overflow ik then ( + let r = size ik in + (* filter out excluded elements that are not in the range *) + let mapped_excl = S.filter (in_range r) s in + `Excluded (mapped_excl, r) + ) + (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) + else if not (should_wrap ik) then ( + top_of ik + ) else ( + (* Else an overflow occurred that we should treat with wrap-around *) + let r = size ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in + match ik with + | IBool -> + begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with + | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) + | true, false -> `Definite Z.one (* Not {0} -> 1 *) + | false, true -> `Definite Z.zero (* Not {1} -> 0 *) + | true, true -> `Bot (* Not {0, 1} -> bot *) + end + | ik -> + `Excluded (mapped_excl, r) + ) + | `Definite x -> + let min, max = Size.range ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + if should_wrap ik then ( + cast_to ik v + ) + else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( + v + ) + else if should_ignore_overflow ik then ( + M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + `Bot + ) + else ( + top_of ik + ) + | `Bot -> `Bot + + let leq x y = match (x,y) with + (* `Bot <= x is always true *) + | `Bot, _ -> true + (* Anything except bot <= bot is always false *) + | _, `Bot -> false + (* Two known values are leq whenever equal *) + | `Definite (x: int_t), `Definite y -> x = y + (* A definite value is leq all exclusion sets that don't contain it *) + | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) + (* No finite exclusion set can be leq than a definite value *) + | `Excluded (xs, xr), `Definite d -> + Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) + | `Excluded (xs,xr), `Excluded (ys,yr) -> + Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) + + let join' ?range ik x y = + match (x,y) with + (* The least upper bound with the bottom element: *) + | `Bot, x -> x + | x, `Bot -> x + (* The case for two known values: *) + | `Definite (x: int_t), `Definite y -> + (* If they're equal, it's just THAT value *) + if x = y then `Definite x + (* Unless one of them is zero, we can exclude it: *) + else + let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in + `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) + (* A known value and an exclusion set... the definite value should no + * longer be excluded: *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> + if not (in_range r x) then + let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in + `Excluded (S.remove x s, R.join a r) + else + `Excluded (S.remove x s, r) + (* For two exclusion sets, only their intersection can be excluded: *) + | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) + + let join ik = join' ik + + + let widen ik x y = + if get_def_exc_widen_by_join () then + join' ik x y + else if equal x y then + x + else + join' ~range:(size ik) ik x y + + + let meet ik x y = + match (x,y) with + (* Greatest LOWER bound with the least element is trivial: *) + | `Bot, _ -> `Bot + | _, `Bot -> `Bot + (* Definite elements are either equal or the glb is bottom *) + | `Definite x, `Definite y -> if x = y then `Definite x else `Bot + (* The glb of a definite element and an exclusion set is either bottom or + * just the element itself, if it isn't in the exclusion set *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x + (* The greatest lower bound of two exclusion sets is their union, this is + * just DeMorgans Law *) + | `Excluded (x,r1), `Excluded (y,r2) -> + let r' = R.meet r1 r2 in + let s' = S.union x y |> S.filter (in_range r') in + `Excluded (s', r') + + let narrow ik x y = x + + let of_int ik x = norm ik @@ `Definite x + let to_int x = match x with + | `Definite x -> Some x + | _ -> None + + let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) + + let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) + let of_bool = of_bool_cmp + let to_bool x = + match x with + | `Definite x -> Some (IntOps.BigIntOps.to_bool x) + | `Excluded (s,r) when S.mem Z.zero s -> Some true + | _ -> None + let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in + norm ik @@ (`Excluded (ex, r)) + + let to_bitfield ik x = + let one_mask = Z.lognot Z.zero + in (one_mask, one_mask) + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let of_excl_list t l = + let r = size t in (* elements in l are excluded from the full range of t! *) + `Excluded (List.fold_right S.add l (S.empty ()), r) + let is_excl_list l = match l with `Excluded _ -> true | _ -> false + let to_excl_list (x:t) = match x with + | `Definite _ -> None + | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) + | `Bot -> None + + let to_incl_list x = match x with + | `Definite x -> Some [x] + | `Excluded _ -> None + | `Bot -> None + + let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) + (* If the Int64 might overflow on us during computation, we instead go to top_range *) + match R.minimal r, R.maximal r with + | _ -> + let rf m = (size % Size.min_for % f) (m r) in + let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in + R.join r1 r2 + + (* Default behaviour for unary operators, simply maps the function to the + * DefExc data structure. *) + let lift1 f ik x = norm ik @@ match x with + | `Excluded (s,r) -> + let s' = S.map f s in + `Excluded (s', apply_range f r) + | `Definite x -> `Definite (f x) + | `Bot -> `Bot + + let lift2 f ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite _ + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (f x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + (* Default behaviour for binary operators that are injective in either + * argument, so that Exclusion Sets can be used: *) + let lift2_inj f ik x y = + let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in + norm ik @@ + match x,y with + (* If both are exclusion sets, there isn't anything we can do: *) + | `Excluded _, `Excluded _ -> top () + (* A definite value should be applied to all members of the exclusion set *) + | `Definite x, `Excluded (s,r) -> def_exc f x s r + (* Same thing here, but we should flip the operator to map it properly *) + | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r + (* The good case: *) + | `Definite x, `Definite y -> `Definite (f x y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The equality check: *) + let eq ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x equal to an exclusion set, if it is a member then NO otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x = y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The inequality check: *) + let ne ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x <> y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x + let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y + + let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y + let mul ?no_ov ik x y = norm ik @@ match x, y with + | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x + | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y + | `Definite a, `Excluded (s,r) + (* Integer multiplication with even numbers is not injective. *) + (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) + | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) + | _ -> lift2_inj Z.mul ik x y + let div ?no_ov ik x y = lift2 Z.div ik x y + let rem ik x y = lift2 Z.rem ik x y + + (* Comparison handling copied from Enums. *) + let handle_bot x y f = match x, y with + | `Bot, `Bot -> `Bot + | `Bot, _ + | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> f () + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let lognot = lift1 Z.lognot + + let logand ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite i -> + (* Except in two special cases *) + if Z.equal i Z.zero then + `Definite Z.zero + else if Z.equal i Z.one then + of_interval IBool (Z.zero, Z.one) + else + top () + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + norm ik @@ lift2 shift_op_big_int ik x y + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + (* TODO: lift does not treat Not {0} as true. *) + let c_logand ik x y = + match to_bool x, to_bool y with + | Some false, _ + | _, Some false -> + of_bool ik false + | _, _ -> + lift2 IntOps.BigIntOps.c_logand ik x y + let c_logor ik x y = + match to_bool x, to_bool y with + | Some true, _ + | _, Some true -> + of_bool ik true + | _, _ -> + lift2 IntOps.BigIntOps.c_logor ik x y + let c_lognot ik = eq ik (of_int ik Z.zero) + + let invariant_ikind e ik (x:t) = + match x with + | `Definite x -> + IntInvariant.of_int e ik x + | `Excluded (s, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let si = IntInvariant.of_excl_list e ik (S.elements s) in + Invariant.(ri && si) + | `Bot -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + let excluded s = from_excl ik s in + let definite x = of_int ik x in + let shrink = function + | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) + | `Bot -> empty + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map excluded (S.arbitrary ()); + 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); + 1, QCheck.always `Bot + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = a + let refine_with_bitfield ik x y = x + let refine_with_interval ik a b = match a, b with + | x, Some(i) -> meet ik x (of_interval ik i) + | _ -> a + let refine_with_excl_list ik a b = match a, b with + | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end diff --git a/src/cdomain/value/cdomains/int/enumsDomain.ml b/src/cdomain/value/cdomains/int/enumsDomain.ml new file mode 100644 index 0000000000..b169f299d2 --- /dev/null +++ b/src/cdomain/value/cdomains/int/enumsDomain.ml @@ -0,0 +1,378 @@ +open IntDomain0 +open IntervalDomain +open DefExcDomain +open GoblintCil + + +(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) +module Enums : S with type int_t = Z.t = struct + module R = Interval32 (* range for exclusion *) + + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) + + type int_t = Z.t + let name () = "enums" + let bot () = failwith "bot () not implemented for Enums" + let top () = failwith "top () not implemented for Enums" + let bot_of ik = Inc (BISet.empty ()) + let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) + let top_of ik = + match ik with + | IBool -> top_bool + | _ -> Exc (BISet.empty (), size ik) + + let range ik = Size.range ik + +(* + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) + let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 + + let show = function + | Inc xs when BISet.is_empty xs -> "bot" + | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" + | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + (* Normalization function for enums, that handles overflows for Inc. + As we do not compute on Excl, we do not have to perform any overflow handling for it. *) + let norm ikind v = + let min, max = range ikind in + (* Whether the value v lies within the values of the specified ikind. *) + let value_in_ikind v = + Z.compare min v <= 0 && Z.compare v max <= 0 + in + match v with + | Inc xs when BISet.for_all value_in_ikind xs -> v + | Inc xs -> + if should_wrap ikind then + Inc (BISet.map (Size.cast ikind) xs) + else if should_ignore_overflow ikind then + Inc (BISet.filter value_in_ikind xs) + else + top_of ikind + | Exc (xs, r) -> + (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: + let range_in_ikind r = + R.leq r (size ikind) + in + let r_min, r_max = min_of_range r, max_of_range r in + assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) + begin match ikind with + | IBool -> + begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with + | false, false -> top_bool (* Not {} -> {0, 1} *) + | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) + | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) + | true, true -> bot_of ikind (* Not {0, 1} -> bot *) + end + | _ -> + v + end + + + let equal_to i = function + | Inc x -> + if BISet.mem i x then + if BISet.is_singleton x then `Eq + else `Top + else `Neq + | Exc (x, r) -> + if BISet.mem i x then `Neq + else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with + | Exc (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + Exc (s, r) + else if ik = IBool then (* downcast to bool *) + if BISet.mem Z.zero s then + Inc (BISet.singleton Z.one) + else + Exc (BISet.empty(), r') + else (* downcast: may overflow *) + Exc ((BISet.empty ()), r') + | Inc xs -> + let casted_xs = BISet.map (Size.cast ik) xs in + if Cil.isSigned ik && not (BISet.equal xs casted_xs) + then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) + else Inc casted_xs + + let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) + + let of_interval ?(suppress_ovwarn=false) ik (x, y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in + norm ik @@ (Exc (ex, r)) + + let join _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.union x y) + | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) + | Exc (x,r), Inc y + | Inc y, Exc (x,r) -> + let r = if BISet.is_empty y + then r + else + let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in + let range = R.join min_el_range max_el_range in + R.join r range + in + Exc (BISet.diff x y, r) + + let meet _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.inter x y) + | Exc (x,r1), Exc (y,r2) -> + let r = R.meet r1 r2 in + let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in + let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in + (* We remove those elements from the exclusion set that do not fit in the range anyway *) + let excl = BISet.union (filter_by_range x) (filter_by_range y) in + Exc (excl, r) + | Inc x, Exc (y,r) + | Exc (y,r), Inc x -> Inc (BISet.diff x y) + + let widen = join + let narrow = meet + let leq a b = + match a, b with + | Inc xs, Exc (ys, r) -> + if BISet.is_empty xs + then true + else + let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in + let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in + (* Check that the xs fit into the range r *) + Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && + (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) + BISet.for_all (fun x -> not (BISet.mem x ys)) xs + | Inc xs, Inc ys -> + BISet.subset xs ys + | Exc (xs, r), Exc (ys, s) -> + Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) + | Exc (xs, r), Inc ys -> + Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) + + let handle_bot x y f = match is_bot x, is_bot y with + | false, false -> f () + | true, false + | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | true, true -> Inc (BISet.empty ()) + + let lift1 f ikind v = norm ikind @@ match v with + | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) + | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) + | _ -> top_of ikind + + let lift2 f (ikind: Cil.ikind) u v = + handle_bot u v (fun () -> + norm ikind @@ match u, v with + | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) + | _,_ -> top_of ikind) + + let lift2 f ikind a b = + try lift2 f ikind a b with Division_by_zero -> top_of ikind + + let neg ?no_ov = lift1 Z.neg + let add ?no_ov ikind a b = + match a, b with + | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,y -> lift2 Z.add ikind x y + let sub ?no_ov = lift2 Z.sub + let mul ?no_ov ikind a b = + match a, b with + | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b + | x,y -> lift2 Z.mul ikind x y + + let div ?no_ov ikind a b = match a, b with + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | x,y -> lift2 Z.div ikind x y + + let rem = lift2 Z.rem + + let lognot = lift1 Z.lognot + let logand = lift2 Z.logand + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + handle_bot x y (fun () -> + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + lift2 shift_op_big_int ik x y) + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + + let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) + let to_bool = function + | Inc e when BISet.is_empty e -> None + | Exc (e,_) when BISet.is_empty e -> None + | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false + | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true + | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true + | _ -> None + let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None + + let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None + let of_excl_list ik xs = + let min_ik, max_ik = Size.range ik in + let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in + norm ik @@ Exc (exc, size ik) + let is_excl_list = BatOption.is_some % to_excl_list + let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None + + let to_bitfield ik x = + let one_mask = Z.lognot Z.zero + in (one_mask, one_mask) + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let c_lognot ik x = + if is_bot x + then x + else + match to_bool x with + | Some b -> of_bool ik (not b) + | None -> top_bool + + let c_logand = lift2 IntOps.BigIntOps.c_logand + let c_logor = lift2 IntOps.BigIntOps.c_logor + let maximal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) + | Exc (excl,r) -> + let rec decrement_while_contained v = + if BISet.mem v excl + then decrement_while_contained (Z.pred v) + else v + in + let range_max = Exclusion.max_of_range r in + Some (decrement_while_contained range_max) + | _ (* bottom case *) -> None + + let minimal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) + | Exc (excl,r) -> + let rec increment_while_contained v = + if BISet.mem v excl + then increment_while_contained (Z.succ v) + else v + in + let range_min = Exclusion.min_of_range r in + Some (increment_while_contained range_min) + | _ (* bottom case *) -> None + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let eq ik x y = + handle_bot x y (fun () -> + match x, y with + | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) + | _, _ -> + if is_bot (meet ik x y) then + (* If the meet is empty, there is no chance that concrete values are equal *) + of_bool ik false + else + top_bool) + + let ne ik x y = c_lognot ik (eq ik x y) + + let invariant_ikind e ik x = + match x with + | Inc ps -> + IntInvariant.of_incl_list e ik (BISet.elements ps) + | Exc (ns, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in + Invariant.(ri && nsi) + + + let arbitrary ik = + let open QCheck.Iter in + let neg s = of_excl_list ik (BISet.elements s) in + let pos s = norm ik (Inc s) in + let shrink = function + | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) + | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map neg (BISet.arbitrary ()); + 10, QCheck.map pos (BISet.arbitrary ()); + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = + let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in + match a, b with + | Inc e, None -> bot_of ik + | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) + | _ -> a + + let refine_with_bitfield ik x y = x + + let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) + + let refine_with_excl_list ik a b = + match b with + | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + + let refine_with_incl_list ik a b = + match a, b with + | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) + | _ -> a + + let project ik p t = t +end diff --git a/src/cdomain/value/cdomains/int/intDomTuple.ml b/src/cdomain/value/cdomains/int/intDomTuple.ml new file mode 100644 index 0000000000..74072b80a6 --- /dev/null +++ b/src/cdomain/value/cdomains/int/intDomTuple.ml @@ -0,0 +1,560 @@ +open IntDomain0 +open IntervalDomain +open IntervalSetDomain +open DefExcDomain +open EnumsDomain +open CongruenceDomain +open BitfieldDomain +open GoblintCil +open Pretty +open PrecisionUtil + +(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) +(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) +module IntDomTupleImpl = struct + include Printable.Std (* for default invariant, tag, ... *) + + open Batteries + type int_t = Z.t + module I1 = SOverflowLifter (DefExc) + module I2 = Interval + module I3 = SOverflowLifter (Enums) + module I4 = SOverflowLifter (Congruence) + module I5 = IntervalSetFunctor (IntOps.BigIntOps) + module I6 = BitfieldFunctor (IntOps.BigIntOps) + + type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option + [@@deriving eq, ord, hash] + + let name () = "intdomtuple" + + (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) + let no_interval = GobTuple.Tuple6.map2 (const None) + let no_intervalSet = GobTuple.Tuple6.map5 (const None) + + type 'a m = (module SOverflow with type t = 'a) + type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) + + (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) + type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) + type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) + type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) + + type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) + type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) + type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] + type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] + type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] + type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) + let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) + let create r x = (* use where values are introduced *) + create r x (int_precision_from_node_or_config ()) + let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) + let create2 r x = (* use where values are introduced *) + create2 r x (int_precision_from_node_or_config ()) + + let no_overflow ik = function + | Some(_, {underflow; overflow}) -> not (underflow || overflow) + | _ -> false + + let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = + let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in + if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( + let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in + let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in + let underflow = underflow_intv && underflow_intv_set in + let overflow = overflow_intv && overflow_intv_set in + set_overflow_flag ~cast ~underflow ~overflow ik; + ); + no_ov + + let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = + let f b g = if b then Some (g x) else None in + let map x = Option.map fst x in + let intv = f p2 @@ r.fi2_ovc (module I2) in + let intv_set = f p5 @@ r.fi2_ovc (module I5) in + ignore (check_ov ~cast:false ik intv intv_set); + map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) + + let create2_ovc ik r x = (* use where values are introduced *) + create2_ovc ik r x (int_precision_from_node_or_config ()) + + + let opt_map2 f ?no_ov = + curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None + + let to_list x = GobTuple.Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) + let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) + + let exists = function + | (Some true, _, _, _, _,_) + | (_, Some true, _, _, _,_) + | (_, _, Some true, _, _,_) + | (_, _, _, Some true, _,_) + | (_, _, _, _, Some true,_) + | (_, _, _, _, _, Some true) + -> true + | _ -> + false + + let for_all = function + | (Some false, _, _, _, _,_) + | (_, Some false, _, _, _,_) + | (_, _, Some false, _, _,_) + | (_, _, _, Some false, _,_) + | (_, _, _, _, Some false,_) + | (_, _, _, _, _, Some false) + -> + false + | _ -> + true + + (* f0: constructors *) + let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () + let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () + let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } + let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } + let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } + let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} + let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } + let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } + let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } + let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } + let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } + let of_bitfield ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_bitfield ik } + + let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_congruence ik a cong + , opt I2.refine_with_congruence ik b cong + , opt I3.refine_with_congruence ik c cong + , opt I4.refine_with_congruence ik d cong + , opt I5.refine_with_congruence ik e cong + , opt I6.refine_with_congruence ik f cong + ) + + let refine_with_interval ik (a, b, c, d, e,f) intv = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_interval ik a intv + , opt I2.refine_with_interval ik b intv + , opt I3.refine_with_interval ik c intv + , opt I4.refine_with_interval ik d intv + , opt I5.refine_with_interval ik e intv + , opt I6.refine_with_interval ik f intv ) + + let refine_with_bitfield ik (a, b, c, d, e,f) bf = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_bitfield ik a bf + , opt I2.refine_with_bitfield ik b bf + , opt I3.refine_with_bitfield ik c bf + , opt I4.refine_with_bitfield ik d bf + , opt I5.refine_with_bitfield ik e bf + , opt I6.refine_with_bitfield ik f bf ) + + let refine_with_excl_list ik (a, b, c, d, e,f) excl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_excl_list ik a excl + , opt I2.refine_with_excl_list ik b excl + , opt I3.refine_with_excl_list ik c excl + , opt I4.refine_with_excl_list ik d excl + , opt I5.refine_with_excl_list ik e excl + , opt I6.refine_with_excl_list ik f excl ) + + let refine_with_incl_list ik (a, b, c, d, e,f) incl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_incl_list ik a incl + , opt I2.refine_with_incl_list ik b incl + , opt I3.refine_with_incl_list ik c incl + , opt I4.refine_with_incl_list ik d incl + , opt I5.refine_with_incl_list ik e incl + , opt I6.refine_with_incl_list ik f incl ) + + + let mapp r (a, b, c, d, e, f) = + let map = BatOption.map in + ( map (r.fp (module I1)) a + , map (r.fp (module I2)) b + , map (r.fp (module I3)) c + , map (r.fp (module I4)) d + , map (r.fp (module I5)) e + , map (r.fp (module I6)) f) + + + let mapp2 r (a, b, c, d, e, f) = + BatOption. + ( map (r.fp2 (module I1)) a + , map (r.fp2 (module I2)) b + , map (r.fp2 (module I3)) c + , map (r.fp2 (module I4)) d + , map (r.fp2 (module I5)) e + , map (r.fp2 (module I6)) f) + + + (* exists/for_all *) + let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } + let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } + let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } + let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } + + let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + ( opt_map2 (r.f2p (module I1)) xa ya + , opt_map2 (r.f2p (module I2)) xb yb + , opt_map2 (r.f2p (module I3)) xc yc + , opt_map2 (r.f2p (module I4)) xd yd + , opt_map2 (r.f2p (module I5)) xe ye + , opt_map2 (r.f2p (module I6)) xf yf) + + (* f2p: binary projections *) + let (%%) f g x = f % (g x) (* composition for binary function g *) + + let leq = + for_all + %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} + + let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) + + let to_excl_list x = + let merge ps = + let (vs, rs) = List.split ps in + let (mins, maxs) = List.split rs in + (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge + + let to_incl_list x = + let hd l = match l with h::t -> h | _ -> [] in + let tl l = match l with h::t -> t | _ -> [] in + let a y = BatSet.of_list (hd y) in + let b y = BatList.map BatSet.of_list (tl y) in + let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge + + let to_bitfield ik x = + let bf_meet (z1,o1) (z2,o2) = (Z.logand z1 z2, Z.logand o1 o2) in + let bf_top = (Z.lognot Z.zero, Z.lognot Z.zero) in + let res_tup = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_bitfield ik } x + in List.fold bf_meet bf_top (to_list res_tup) + + let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in + if n = 1 then Some (List.hd xs) + else ( + if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) + None + ) + let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } + + let pretty () x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) + | _ -> + mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x + |> to_list + |> (fun xs -> + text "(" ++ ( + try + List.reduce (fun a b -> a ++ text "," ++ b) xs + with Invalid_argument _ -> + nil) + ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) + + let refine_functions ik : (t -> t) list = + let maybe reffun ik domtup dom = + match dom with Some y -> reffun ik domtup y | _ -> domtup + in + [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); + (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e, f) b); (* TODO: get interval across all domains with minimal and maximal *) + (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e, f) d); + (fun (a, b, c, d, e, f) -> maybe refine_with_bitfield ik (a, b, c, d, e, f) f)] + + let refine ik ((a, b, c, d, e,f) : t ) : t = + let dt = ref (a, b, c, d, e,f) in + (match get_refinement () with + | "never" -> () + | "once" -> + List.iter (fun f -> dt := f !dt) (refine_functions ik); + | "fixpoint" -> + let quit_loop = ref false in + while not !quit_loop do + let old_dt = !dt in + List.iter (fun f -> dt := f !dt) (refine_functions ik); + quit_loop := equal old_dt !dt; + if is_bot !dt then dt := bot_of ik; quit_loop := true; + if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; + done; + | _ -> () + ); !dt + + + (* map with overflow check *) + let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = + let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in + let intv = map (r.f1_ovc (module I2)) b in + let intv_set = map (r.f1_ovc (module I5)) e in + let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a + , BatOption.map fst intv + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d + , BatOption.map fst intv_set + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) + + (* map2 with overflow check *) + let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in + let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in + let no_ov = check_ov ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya + , BatOption.map fst intv + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd + , BatOption.map fst intv_set + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) + + let map ik r (a, b, c, d, e, f) = + refine ik + BatOption. + ( map (r.f1 (module I1)) a + , map (r.f1 (module I2)) b + , map (r.f1 (module I3)) c + , map (r.f1 (module I4)) d + , map (r.f1 (module I5)) e + , map (r.f1 (module I6)) f) + + let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = + let r = + ( opt_map2 (r.f2 (module I1)) xa ya + , opt_map2 (r.f2 (module I2)) xb yb + , opt_map2 (r.f2 (module I3)) xc yc + , opt_map2 (r.f2 (module I4)) xd yd + , opt_map2 (r.f2 (module I5)) xe ye + , opt_map2 (r.f2 (module I6)) xf yf) + in + if norefine then r else refine ik r + + + (* f1: unary ops *) + let neg ?no_ov ik = + mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} + + let lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} + + let c_lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = + mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} + + (* fp: projections *) + let equal_to i x = + let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> GobTuple.Tuple6.enum |> List.of_enum |> List.filter_map identity in + if List.mem `Eq xs then `Eq else + if List.mem `Neq xs then `Neq else + `Top + + let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } + let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } + let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } + (* others *) + let show x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v + | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x + |> to_list + |> String.concat "; " + let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } + + (* `map/opt_map` are used by `project` *) + let opt_map b f = + curry @@ function None, true -> f | x, y when y || b -> x | _ -> None + let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = + ( opt_map keep (r.f3 (module I1)) i1 b1 + , opt_map keep (r.f3 (module I2)) i2 b2 + , opt_map keep (r.f3 (module I3)) i3 b3 + , opt_map keep (r.f3 (module I4)) i4 b4 + , opt_map keep (r.f3 (module I5)) i5 b5 + , opt_map keep (r.f3 (module I6)) i6 b6) + + (** Project tuple t to precision p + * We have to deactivate IntDomains after the refinement, since we might + * lose information if we do it before. E.g. only "Interval" is active + * and shall be projected to only "Def_Exc". By seting "Interval" to None + * before refinement we have no information for "Def_Exc". + * + * Thus we have 3 Steps: + * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element + * 2. Refine the padded t + * 3. Set elements of t to `None` if p is false for this element + * + * Side Note: + * ~keep is used to reuse `map/opt_map` for Step 1 and 3. + * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. + * This way we won't loose any information for the refinement. + * ~keep:false will set the elements to `None` as defined by p *) + let project ik (p: int_precision) t = + let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in + let t_refined = refine ik t_padded in + map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p + + + (* f2: binary ops *) + let join ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} + + let meet ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} + + let widen ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} + + let narrow ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} + + let add ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} + + let sub ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} + + let mul ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} + + let div ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} + + let rem ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} + + let lt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} + + let gt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} + + let le ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} + + let ge ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} + + let eq ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} + + let ne ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} + + let logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} + + let logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} + + let logxor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} + + let shift_left ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} + + let shift_right ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} + + let c_logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} + + let c_logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} + + + (* printing boilerplate *) + let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y + let printXml f x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) + | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) + + let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = + (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) + let simplify_int fallback = + match to_int x with + | Some v -> + (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) + IntInvariant.of_int e ik v + | None -> + fallback () + in + let simplify_all () = + match to_incl_list x with + | Some ps -> + (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) + IntInvariant.of_incl_list e ik ps + | None -> + (* Get interval bounds from all domains (intervals and exclusion set ranges). *) + let min = minimal x in + let max = maximal x in + let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) + (* "Refine" out-of-bounds exclusions for simpler output. *) + let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in + let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in + Invariant.( + IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) + IntInvariant.of_excl_list e ik ns && + Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) + Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) + ) + in + let simplify_none () = + let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in + List.fold_left (fun a i -> + Invariant.(a && i) + ) (Invariant.top ()) is + in + match GobConfig.get_string "ana.base.invariant.int.simplify" with + | "none" -> simplify_none () + | "int" -> simplify_int simplify_none + | "all" -> simplify_int simplify_all + | _ -> assert false + + let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) + + let relift (a, b, c, d, e, f) = + (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) +end + +module IntDomTuple = +struct + module I = IntDomLifter (IntDomTupleImpl) + include I + + let top () = failwith "top in IntDomTuple not supported. Use top_of instead." + let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} + + let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} +end + +let of_const (i, ik, str) = IntDomTuple.of_int ik i \ No newline at end of file diff --git a/src/cdomain/value/cdomains/int/intervalDomain.ml b/src/cdomain/value/cdomains/int/intervalDomain.ml new file mode 100644 index 0000000000..bef586dbb7 --- /dev/null +++ b/src/cdomain/value/cdomains/int/intervalDomain.ml @@ -0,0 +1,477 @@ +open IntDomain0 +open GoblintCil + + +module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = +struct + let name () = "intervals" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] + module IArith = IntervalArith (Ints_t) + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + let top_of ik = Some (range ik) + let bot () = None + let bot_of ik = bot () (* TODO: improve *) + + let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) -> + if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> + if Ints_t.compare x y > 0 then + (None,{underflow=false; overflow=false}) + else ( + let (min_ik, max_ik) = range ik in + let underflow = Ints_t.compare min_ik x > 0 in + let overflow = Ints_t.compare max_ik y < 0 in + let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in + let v = + if underflow || overflow then + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in + let resdiff = Ints_t.abs (Ints_t.sub y x) in + if Ints_t.compare resdiff diff > 0 then + top_of ik + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if Ints_t.compare l u <= 0 then + Some (l, u) + else + (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) + top_of ik + else if not cast && should_ignore_overflow ik then + let tl, tu = BatOption.get @@ top_of ik in + Some (Ints_t.max tl x, Ints_t.min tu y) + else + top_of ik + else + Some (x,y) + in + (v, ov_info) + ) + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst + + let meet ik (x:t) y = + match x, y with + | None, z | z, None -> None + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst + + (* TODO: change to_int signature so it returns a big_int *) + let to_int x = Option.bind x (IArith.to_int) + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) + + let of_bitfield ik x = + let min ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = Ints_t.logand signBit o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) + else Ints_t.lognot z + in let max ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.logand signMask o + else o + in fst (norm ik (Some (min ik x, max ik x))) + + let of_int ik (x: int_t) = of_interval ik (x,x) + let zero = Some IArith.zero + let one = Some IArith.one + let top_bool = Some IArith.top_bool + + let to_bitfield ik z = + match z with None -> (Ints_t.lognot Ints_t.zero, Ints_t.lognot Ints_t.zero) | Some (x,y) -> + let (min_ik, max_ik) = Size.range ik in + let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in + let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in + + let rec analyze_bits pos (acc_z, acc_o) = + if pos < 0 then (acc_z, acc_o) + else + let position = Ints_t.shift_left Ints_t.one pos in + let mask = Ints_t.sub position Ints_t.one in + let remainder = Ints_t.logand startv mask in + + let without_remainder = Ints_t.sub startv remainder in + let bigger_number = Ints_t.add without_remainder position in + + let bit_status = + if Ints_t.compare bigger_number endv <= 0 then + `top + else + if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then + `one + else + `zero + in + + let new_acc = + match bit_status with + | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) + | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) + | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) + + in + analyze_bits (pos - 1) new_acc + in + let result = analyze_bits (Size.bit ik - 1) (Ints_t.zero, Ints_t.zero) in + let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) + in casted + + let of_bool _ik = function true -> one | false -> zero + let to_bool (a: t) = match a with + | None -> None + | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) + + (* TODO: change signature of maximal, minimal to return big_int*) + let maximal = function None -> None | Some (x,y) -> Some y + let minimal = function None -> None | Some (x,y) -> Some x + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) + + let widen ik x y = + match x, y with + | None, z | z, None -> z + | Some (l0,u0), Some (l1,u1) -> + let (min_ik, max_ik) = range ik in + let threshold = get_interval_threshold_widening () in + let l2 = + if Ints_t.compare l0 l1 = 0 then l0 + else if threshold then IArith.lower_threshold l1 min_ik + else min_ik + in + let u2 = + if Ints_t.compare u0 u1 = 0 then u0 + else if threshold then IArith.upper_threshold u1 max_ik + else max_ik + in + norm ik @@ Some (l2,u2) |> fst + let widen ik x y = + let r = widen ik x y in + if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; + assert (leq x y); (* TODO: remove for performance reasons? *) + r + + let narrow ik x y = + match x, y with + | _,None | None, _ -> None + | Some (x1,x2), Some (y1,y2) -> + let threshold = get_interval_threshold_widening () in + let (min_ik, max_ik) = range ik in + let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in + let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in + norm ik @@ Some (lr,ur) |> fst + + + let narrow ik x y = + if get_interval_narrow_by_meet () then + meet ik x y + else + narrow ik x y + + let log f ~annihilator ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) ~annihilator:true + let c_logand = log (&&) ~annihilator:false + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let bit f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + let bitcomp f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let logxor = bit (fun _ik -> Ints_t.logxor) + + let logand ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) + | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst + | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst + | _ -> top_of ik + + let logor = bit (fun _ik -> Ints_t.logor) + + let bit1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_int i1 with + | Some x -> of_int ik (f ik x) |> fst + | _ -> top_of ik + + let lognot = bit1 (fun _ik -> Ints_t.lognot) + let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) + + let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) + + let binary_op_with_norm ?no_ov op ik x y = match x, y with + | None, None -> (None, {overflow=false; underflow= false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some x, Some y -> norm ik @@ Some (op x y) + + let add ?no_ov = binary_op_with_norm IArith.add + let mul ?no_ov = binary_op_with_norm IArith.mul + let sub ?no_ov = binary_op_with_norm IArith.sub + + let shift_left ik a b = + match is_bot a, is_bot b with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) + | _ -> + match a, minimal b, maximal b with + | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> + (try + let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in + norm ik @@ Some r + with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let rem ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (xl, xu), Some (yl, yu) -> + if is_top_of ik x && is_top_of ik y then + (* This is needed to preserve soundness also on things bigger than int32 e.g. *) + (* x: 3803957176L -> T in Interval32 *) + (* y: 4209861404L -> T in Interval32 *) + (* x % y: 3803957176L -> T in Interval32 *) + (* T in Interval32 is [-2147483648,2147483647] *) + (* the code below computes [-2147483647,2147483647] for this though which is unsound *) + top_of ik + else + (* If we have definite values, Ints_t.rem will give a definite result. + * Otherwise we meet with a [range] the result can be in. + * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. + * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) + let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in + let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in + let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range + + let rec div ?no_ov ik x y = + match x, y with + | None, None -> (bot (),{underflow=false; overflow=false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | (Some (x1,x2) as x), (Some (y1,y2) as y) -> + begin + let is_zero v = Ints_t.compare v Ints_t.zero = 0 in + match y1, y2 with + | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) + | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) + | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) + | _ -> binary_op_with_norm IArith.div ik x y + end + + let ne ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik true + else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then + of_bool ik false + else top_bool + + let eq ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then + of_bool ik true + else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik false + else top_bool + + let ge ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 then of_bool ik true + else if Ints_t.compare x2 y1 < 0 then of_bool ik false + else top_bool + + let le ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 <= 0 then of_bool ik true + else if Ints_t.compare y2 x1 < 0 then of_bool ik false + else top_bool + + let gt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 then of_bool ik true + else if Ints_t.compare x2 y1 <= 0 then of_bool ik false + else top_bool + + let lt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 < 0 then of_bool ik true + else if Ints_t.compare y2 x1 <= 0 then of_bool ik false + else top_bool + + let invariant_ikind e ik = function + | Some (x1, x2) -> + let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in + IntInvariant.of_interval e ik (x1', x2') + | None -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink = function + | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | None -> empty + in + QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) + + let modulo n k = + let result = Ints_t.rem n k in + if Ints_t.compare result Ints_t.zero >= 0 then result + else Ints_t.add result k + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None + else if Ints_t.equal m Ints_t.zero then + Some (c, c) + else + let (min_ik, max_ik) = range ik in + let rcx = + if Ints_t.equal x min_ik then x else + Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in + let lcy = + if Ints_t.equal y max_ik then y else + Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in + if Ints_t.compare rcx lcy > 0 then None + else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst + else norm ik @@ Some (rcx, lcy) |> fst + | _ -> None + + let refine_with_congruence ik x y = + let refn = refine_with_congruence ik x y in + if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; + refn + + let refine_with_bitfield ik a b = + let interv = of_bitfield ik b in + meet ik a interv + + let refine_with_interval ik a b = meet ik a b + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + match intv, excl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls, (rl, rh)) -> + let rec shrink op b = + let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in + if not (Ints_t.equal b new_b) then shrink op new_b else new_b + in + let (min_ik, max_ik) = range ik in + let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in + let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in + let intv' = norm ik @@ Some (l', u') |> fst in + let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in + meet ik intv' range + + let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = + match intv, incl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls) -> + let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in + let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in + match min None ls, max None ls with + | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) + | _, _-> intv + + let project ik p t = t +end + +module Interval = IntervalFunctor (IntOps.BigIntOps) +module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) diff --git a/src/cdomain/value/cdomains/int/intervalSetDomain.ml b/src/cdomain/value/cdomains/int/intervalSetDomain.ml new file mode 100644 index 0000000000..8b40fd5d11 --- /dev/null +++ b/src/cdomain/value/cdomains/int/intervalSetDomain.ml @@ -0,0 +1,567 @@ +open IntDomain0 +open IntervalDomain +open GoblintCil + + +(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) +module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = +struct + + module Interval = IntervalFunctor (Ints_t) + module IArith = IntervalArith (Ints_t) + + + let name () = "interval_sets" + + type int_t = Ints_t.t + + let (>.) a b = Ints_t.compare a b > 0 + let (=.) a b = Ints_t.compare a b = 0 + let (<.) a b = Ints_t.compare a b < 0 + let (>=.) a b = Ints_t.compare a b >= 0 + let (<=.) a b = Ints_t.compare a b <= 0 + let (+.) a b = Ints_t.add a b + let (-.) a b = Ints_t.sub a b + + (* + Each domain's element is guaranteed to be in canonical form. That is, each interval contained + inside the set does not overlap with each other and they are not adjacent. + *) + type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + + let top_of ik = [range ik] + + let bot () = [] + + let bot_of ik = bot () + + let show (x: t) = + let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in + List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" + + (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) + type event = Enter of Ints_t.t | Exit of Ints_t.t + + let unbox_event = function Enter x -> x | Exit x -> x + + let cmp_events x y = + (* Deliberately comparing ints first => Cannot be derived *) + let res = Ints_t.compare (unbox_event x) (unbox_event y) in + if res <> 0 then res + else + begin + match (x, y) with + | (Enter _, Exit _) -> -1 + | (Exit _, Enter _) -> 1 + | (_, _) -> 0 + end + + let interval_set_to_events (xs: t) = + List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs + + let two_interval_sets_to_events (xs: t) (ys: t) = + let xs = interval_set_to_events xs in + let ys = interval_set_to_events ys in + List.merge cmp_events xs ys + + (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap + This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) + let combined_event_list lattice_op (xs:event list) = + let l = match lattice_op with `Join -> 1 | `Meet -> 2 in + let aux (interval_count, acc) = function + | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) + | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) + in + List.fold_left aux (0, []) xs |> snd |> List.rev + + let rec events_to_intervals = function + | [] -> [] + | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) + | _ -> failwith "Invalid events list" + + let remove_empty_gaps (xs: t) = + let aux acc (l, r) = match acc with + | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' + | _ -> (l, r)::acc + in + List.fold_left aux [] xs |> List.rev + + let canonize (xs: t) = + interval_set_to_events xs |> + List.sort cmp_events |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let unop (x: t) op = match x with + | [] -> [] + | _ -> canonize @@ List.concat_map op x + + let binop (x: t) (y: t) op : t = match x, y with + | [], _ -> [] + | _, [] -> [] + | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) + + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let minimal = function + | [] -> None + | (x, _)::_ -> Some x + + let maximal = function + | [] -> None + | xs -> Some (BatList.last xs |> snd) + + let equal_to_interval i (a, b) = + if a =. b && b =. i then + `Eq + else if a <=. i && i <=. b then + `Top + else + `Neq + + let equal_to i xs = match List.map (equal_to_interval i) xs with + | [] -> failwith "unsupported: equal_to with bottom" + | [`Eq] -> `Eq + | ys when List.for_all ((=) `Neq) ys -> `Neq + | _ -> `Top + + let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = + if x >. y then + ([],{underflow=false; overflow=false}) + else + let (min_ik, max_ik) = range ik in + let underflow = min_ik >. x in + let overflow = max_ik <. y in + let v = if underflow || overflow then + begin + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (max_ik -. min_ik) in + let resdiff = Ints_t.abs (y -. x) in + if resdiff >. diff then + [range ik] + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if l <=. u then + [(l, u)] + else + (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) + [(min_ik, u); (l, max_ik)] + else if not cast && should_ignore_overflow ik then + [Ints_t.max min_ik x, Ints_t.min max_ik y] + else + [range ik] + end + else + [(x,y)] + in + if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) + + let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = + let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) + + let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> + let res = List.map op (BatList.cartesian_product x y) in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let unary_op_with_norm op (ik:ikind) (x: t) = match x with + | [] -> ([],{overflow=false; underflow=false}) + | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x + + let rec leq (xs: t) (ys: t) = + let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in + match xs, ys with + | [], _ -> true + | _, [] -> false + | (xl,xr)::xs', (yl,yr)::ys' -> + if leq_interval (xl,xr) (yl,yr) then + leq xs' ys + else if xr <. yl then + false + else + leq xs ys' + + let join ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let meet ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Meet |> + events_to_intervals + + let to_int = function + | [x] -> IArith.to_int x + | _ -> None + + let zero = [IArith.zero] + let one = [IArith.one] + let top_bool = [IArith.top_bool] + + let not_bool (x:t) = + let is_false x = equal x zero in + let is_true x = equal x one in + if is_true x then zero else if is_false x then one else top_bool + + let to_bool = function + | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false + | x -> if leq zero x then None else Some true + + let of_bool _ = function true -> one | false -> zero + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) + + let of_bitfield ik x = + let min ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in + let isNegative = Ints_t.logand signBit o <> Ints_t.zero in + if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) + else Ints_t.lognot z + in let max ik (z,o) = + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.logand signMask o + else o + in fst (norm_interval ik (min ik x, max ik x)) + + let to_bitfield ik x = + let joinbf (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) in + let rec from_list is acc = match is with + [] -> acc | + j::js -> from_list js (joinbf acc (Interval.to_bitfield ik (Some j))) + in from_list x (Ints_t.zero, Ints_t.zero) + + let of_int ik (x: int_t) = of_interval ik (x, x) + + let lt ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <. min_y then + of_bool ik true + else if min_x >=. max_y then + of_bool ik false + else + top_bool + + let le ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <=. min_y then + of_bool ik true + else if min_x >. max_y then + of_bool ik false + else + top_bool + + let gt ik x y = not_bool @@ le ik x y + + let ge ik x y = not_bool @@ lt ik x y + + let eq ik x y = match x, y with + | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> + one + | _ -> + if is_bot (meet ik x y) then + zero + else + top_bool + + let ne ik x y = not_bool @@ eq ik x y + let interval_to_int i = Interval.to_int (Some i) + let interval_to_bool i = Interval.to_bool (Some i) + + let log f ik (i1, i2) = + match (interval_to_bool i1, interval_to_bool i2) with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + + let bit f ik (i1, i2) = + match (interval_to_int i1), (interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + + let bitcomp f ik (i1, i2) = + match (interval_to_int i1, interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) + | _, _ -> (top_of ik,{overflow=false; underflow=false}) + + let logand ik x y = + let interval_logand = bit Ints_t.logand ik in + binop x y interval_logand + + let logor ik x y = + let interval_logor = bit Ints_t.logor ik in + binop x y interval_logor + + let logxor ik x y = + let interval_logxor = bit Ints_t.logxor ik in + binop x y interval_logxor + + let lognot ik x = + let interval_lognot i = + match interval_to_int i with + | Some x -> of_int ik (Ints_t.lognot x) |> fst + | _ -> top_of ik + in + unop x interval_lognot + + let shift_left ik x y = + let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftleft + + let shift_right ik x y = + let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftright + + let c_lognot ik x = + let log1 f ik i1 = + match interval_to_bool i1 with + | Some x -> of_bool ik (f x) + | _ -> top_of ik + in + let interval_lognot = log1 not ik in + unop x interval_lognot + + let c_logand ik x y = + let interval_logand = log (&&) ik in + binop x y interval_logand + + let c_logor ik x y = + let interval_logor = log (||) ik in + binop x y interval_logor + + let add ?no_ov = binary_op_with_norm IArith.add + let sub ?no_ov = binary_op_with_norm IArith.sub + let mul ?no_ov = binary_op_with_norm IArith.mul + let neg ?no_ov = unary_op_with_norm IArith.neg + + let div ?no_ov ik x y = + let rec interval_div x (y1, y2) = begin + let top_of ik = top_of ik |> List.hd in + let is_zero v = v =. Ints_t.zero in + match y1, y2 with + | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) + | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) + | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik + | _ -> IArith.div x (y1, y2) + end + in binary_op_with_norm interval_div ik x y + + let rem ik x y = + let interval_rem (x, y) = + if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then + top_of ik + else + let (xl, xu) = x in let (yl, yu) = y in + let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in + let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in + let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit Ints_t.rem ik (x, y)) [range] + in + binop x y interval_rem + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x + + (* + narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys + *) + let narrow ik xs ys = match xs ,ys with + | [], _ -> [] | _ ,[] -> xs + | _, _ -> + let min_xs = minimal xs |> Option.get in + let max_xs = maximal xs |> Option.get in + let min_ys = minimal ys |> Option.get in + let max_ys = maximal ys |> Option.get in + let min_range,max_range = range ik in + let threshold = get_interval_threshold_widening () in + let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in + let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in + xs + |> (function (_, y)::z -> (min, y)::z | _ -> []) + |> List.rev + |> (function (x, _)::z -> (x, max)::z | _ -> []) + |> List.rev + + (* + 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. + and joins all intervals in xs assigned to the same interval in ys as one interval. + 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. + 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) + + The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. + *) + let widen ik xs ys = + let (min_ik,max_ik) = range ik in + let threshold = GobConfig.get_bool "ana.int.interval_threshold_widening" in + let upper_threshold (_,u) = IArith.upper_threshold u max_ik in + let lower_threshold (l,_) = IArith.lower_threshold l min_ik in + (*obtain partitioning of xs intervals according to the ys interval that includes them*) + let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= + match xs,ys with + | _, [] -> [] + | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys + | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) + | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys + in + let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in + (*merge a pair of adjacent partitions*) + let merge_pair ik (a,b) (c,d) = + let new_a = function + | None -> Some (upper_threshold b, upper_threshold b) + | Some (ax,ay) -> Some (ax, upper_threshold b) + in + let new_c = function + | None -> Some (lower_threshold d, lower_threshold d) + | Some (cx,cy) -> Some (lower_threshold d, cy) + in + if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then + [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] + else + [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] + in + let partitions_are_approaching part_left part_right = match part_left, part_right with + | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) + | _,_ -> false + in + (*merge all approaching pairs of adjacent partitions*) + let rec merge_list ik = function + | [] -> [] + | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) + | x::xs -> x :: merge_list ik xs + in + (*expands left extremity*) + let widen_left = function + | [] -> [] + | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts + | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts + | x -> x + in + (*expands right extremity*) + let widen_right x = + let map_rightmost = function + | [] -> [] + | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts + | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts + | x -> x + in + List.rev x |> map_rightmost |> List.rev + in + interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd + + let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) + + let invariant_ikind e ik xs = + List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> + let open Invariant in List.fold_left (||) (bot ()) + + let modulo n k = + let result = Ints_t.rem n k in + if result >=. Ints_t.zero then result + else result +. k + + let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = + let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =. Ints_t.zero && (c <. x || c >. y) then [] + else if m =. Ints_t.zero then + [(c, c)] + else + let (min_ik, max_ik) = range ik in + let rcx = + if x =. min_ik then x else + x +. (modulo (c -. x) (Ints_t.abs m)) in + let lcy = + if y =. max_ik then y else + y -. (modulo (y -. c) (Ints_t.abs m)) in + if rcx >. lcy then [] + else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst + else norm_interval ik (rcx, lcy) |> fst + | _ -> [] + in + List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs + + let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] + + let refine_with_bitfield ik x y = + let interv = of_bitfield ik y in + meet ik x interv + + let refine_with_incl_list ik intvs = function + | None -> intvs + | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) + + let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = + let intv1 = (min, excl -. Ints_t.one) in + let intv2 = (excl +. Ints_t.one, max) in + norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst + + let of_excl_list ik (excls: int_t list) = + let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in + let res = List.fold_left (meet ik) (top_of ik) excl_list in + res + + let refine_with_excl_list ik (intv : t) = function + | None -> intv + | Some (xs, range) -> + let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = + excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl + in + let excl_list = List.map (excl_to_intervalset ik range) xs in + List.fold_left (meet ik) intv excl_list + + let project ik p t = t + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let list_pair_arb = QCheck.small_list pair_arb in + let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in + let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list + in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) +end + +module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 80d570f341..991fb114cf 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1,4529 +1,9 @@ -open GoblintCil -open GobConfig -open Pretty -open PrecisionUtil - -module M = Messages - -let (%) = Batteries.(%) -let (|?) = Batteries.(|?) - -exception IncompatibleIKinds of string -exception Unknown -exception Error -exception ArithmeticOnIntegerBot of string - -(** Define records that hold mutable variables representing different Configuration values. - * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) -type ana_int_config_values = { - mutable interval_threshold_widening : bool option; - mutable interval_narrow_by_meet : bool option; - mutable def_exc_widen_by_join : bool option; - mutable interval_threshold_widening_constants : string option; - mutable refinement : string option; -} - -let ana_int_config: ana_int_config_values = { - interval_threshold_widening = None; - interval_narrow_by_meet = None; - def_exc_widen_by_join = None; - interval_threshold_widening_constants = None; - refinement = None; -} - -let get_interval_threshold_widening () = - if ana_int_config.interval_threshold_widening = None then - ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); - Option.get ana_int_config.interval_threshold_widening - -let get_interval_narrow_by_meet () = - if ana_int_config.interval_narrow_by_meet = None then - ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); - Option.get ana_int_config.interval_narrow_by_meet - -let get_def_exc_widen_by_join () = - if ana_int_config.def_exc_widen_by_join = None then - ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); - Option.get ana_int_config.def_exc_widen_by_join - -let get_interval_threshold_widening_constants () = - if ana_int_config.interval_threshold_widening_constants = None then - ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); - Option.get ana_int_config.interval_threshold_widening_constants - -let get_refinement () = - if ana_int_config.refinement = None then - ana_int_config.refinement <- Some (get_string "ana.int.refinement"); - Option.get ana_int_config.refinement - - - -(** Whether for a given ikind, we should compute with wrap-around arithmetic. - * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) -let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" - -(** Whether for a given ikind, we should assume there are no overflows. - * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) -let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" - -let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds -let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) - -type overflow_info = { overflow: bool; underflow: bool;} - -let set_overflow_flag ~cast ~underflow ~overflow ik = - if !AnalysisState.executing_speculative_computations then - (* Do not produce warnings when the operations are not actually happening in code *) - () - else - let signed = Cil.isSigned ik in - if !AnalysisState.postsolving && signed && not cast then - AnalysisState.svcomp_may_overflow := true; - let sign = if signed then "Signed" else "Unsigned" in - match underflow, overflow with - | true, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign - | true, false -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign - | false, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign - | false, false -> assert false - -let reset_lazy () = - ResettableLazy.reset widening_thresholds; - ResettableLazy.reset widening_thresholds_desc; - ana_int_config.interval_threshold_widening <- None; - ana_int_config.interval_narrow_by_meet <- None; - ana_int_config.def_exc_widen_by_join <- None; - ana_int_config.interval_threshold_widening_constants <- None; - ana_int_config.refinement <- None - -module type Arith = -sig - type t - val neg: t -> t - val add: t -> t -> t - val sub: t -> t -> t - val mul: t -> t -> t - val div: t -> t -> t - val rem: t -> t -> t - - val lt: t -> t -> t - val gt: t -> t -> t - val le: t -> t -> t - val ge: t -> t -> t - val eq: t -> t -> t - val ne: t -> t -> t - - val lognot: t -> t - val logand: t -> t -> t - val logor : t -> t -> t - val logxor: t -> t -> t - - val shift_left : t -> t -> t - val shift_right: t -> t -> t - - val c_lognot: t -> t - val c_logand: t -> t -> t - val c_logor : t -> t -> t - -end - -module type ArithIkind = -sig - type t - val neg: Cil.ikind -> t -> t - val add: Cil.ikind -> t -> t -> t - val sub: Cil.ikind -> t -> t -> t - val mul: Cil.ikind -> t -> t -> t - val div: Cil.ikind -> t -> t -> t - val rem: Cil.ikind -> t -> t -> t - - val lt: Cil.ikind -> t -> t -> t - val gt: Cil.ikind -> t -> t -> t - val le: Cil.ikind -> t -> t -> t - val ge: Cil.ikind -> t -> t -> t - val eq: Cil.ikind -> t -> t -> t - val ne: Cil.ikind -> t -> t -> t - - val lognot: Cil.ikind -> t -> t - val logand: Cil.ikind -> t -> t -> t - val logor : Cil.ikind -> t -> t -> t - val logxor: Cil.ikind -> t -> t -> t - - val shift_left : Cil.ikind -> t -> t -> t - val shift_right: Cil.ikind -> t -> t -> t - - val c_lognot: Cil.ikind -> t -> t - val c_logand: Cil.ikind -> t -> t -> t - val c_logor : Cil.ikind -> t -> t -> t - -end - -(* Shared functions between S and Z *) -module type B = -sig - include Lattice.S - type int_t - val bot_of: Cil.ikind -> t - val top_of: Cil.ikind -> t - val to_int: t -> int_t option - val equal_to: int_t -> t -> [`Eq | `Neq | `Top] - - val to_bool: t -> bool option - val to_excl_list: t -> (int_t list * (int64 * int64)) option - val of_excl_list: Cil.ikind -> int_t list -> t - val is_excl_list: t -> bool - - val to_incl_list: t -> int_t list option - - val maximal : t -> int_t option - val minimal : t -> int_t option - - val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t -end - -(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) -module type IkindUnawareS = -sig - include B - include Arith with type t := t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: int_t -> t - val of_bool: bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val of_bitfield: Cil.ikind -> int_t * int_t -> t - val arbitrary: unit -> t QCheck.arbitrary - val invariant: Cil.exp -> t -> Invariant.t -end - -(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) -module type S = -sig - include B - include ArithIkind with type t:= t - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val neg : ?no_ov:bool -> Cil.ikind -> t -> t - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t - - val join: Cil.ikind -> t -> t -> t - val meet: Cil.ikind -> t -> t -> t - val narrow: Cil.ikind -> t -> t -> t - val widen: Cil.ikind -> t -> t -> t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val of_bitfield: Cil.ikind -> int_t * int_t -> t - val to_bitfield: Cil.ikind -> t -> int_t * int_t - val is_top_of: Cil.ikind -> t -> bool - val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t - - val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_bitfield: Cil.ikind -> t -> (int_t * int_t) -> t - val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t - val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t - - val project: Cil.ikind -> int_precision -> t -> t - val arbitrary: Cil.ikind -> t QCheck.arbitrary -end - -module type SOverflow = -sig - - include S - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val of_int : Cil.ikind -> int_t -> t * overflow_info - - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - - val shift_left : Cil.ikind -> t -> t -> t * overflow_info - - val shift_right : Cil.ikind -> t -> t -> t * overflow_info -end - -module type Y = -sig - (* include B *) - include B - include Arith with type t:= t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val of_bitfield: Cil.ikind -> int_t * int_t -> t - val to_bitfield: Cil.ikind -> t -> int_t * int_t - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val is_top_of: Cil.ikind -> t -> bool - - val project: int_precision -> t -> t - val invariant: Cil.exp -> t -> Invariant.t -end - -module type Z = Y with type int_t = Z.t - - -module IntDomLifter (I : S) = -struct - open Cil - type int_t = I.int_t - type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] - - let ikind {ikind; _} = ikind - - (* Helper functions *) - let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) - let lift op x = {x with v = op x.ikind x.v } - (* For logical operations the result is of type int *) - let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} - let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } - let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} - - let bot_of ikind = { v = I.bot_of ikind; ikind} - let bot () = failwith "bot () is not implemented for IntDomLifter." - let is_bot x = I.is_bot x.v - let top_of ikind = { v = I.top_of ikind; ikind} - let top () = failwith "top () is not implemented for IntDomLifter." - let is_top x = I.is_top x.v - - (* Leq does not check for ikind, because it is used in invariant with arguments of different type. - TODO: check ikinds here and fix invariant to work with right ikinds *) - let leq x y = I.leq x.v y.v - let join = lift2 I.join - let meet = lift2 I.meet - let widen = lift2 I.widen - let narrow = lift2 I.narrow - - let show x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - "⊤" - else - I.show x.v (* TODO add ikind to output *) - let pretty () x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - Pretty.text "⊤" - else - I.pretty () x.v (* TODO add ikind to output *) - let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) - let printXml o x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - BatPrintf.fprintf o "\n\n⊤\n\n\n" - else - I.printXml o x.v (* TODO add ikind to output *) - (* This is for debugging *) - let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" - let to_yojson x = I.to_yojson x.v - let invariant e x = - let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in - I.invariant_ikind e' x.ikind x.v - let tag x = I.tag x.v - let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." - let to_int x = I.to_int x.v - let of_int ikind x = { v = I.of_int ikind x; ikind} - let equal_to i x = I.equal_to i x.v - let to_bool x = I.to_bool x.v - let of_bool ikind b = { v = I.of_bool ikind b; ikind} - let to_excl_list x = I.to_excl_list x.v - let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} - let is_excl_list x = I.is_excl_list x.v - let to_incl_list x = I.to_incl_list x.v - let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} - let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} - let of_bitfield ikind (z,o) = {v = I.of_bitfield ikind (z,o); ikind} - let to_bitfield ikind x = I.to_bitfield ikind x.v - - let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} - let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} - let maximal x = I.maximal x.v - let minimal x = I.minimal x.v - - let neg = lift I.neg - let add = lift2 I.add - let sub = lift2 I.sub - let mul = lift2 I.mul - let div = lift2 I.div - let rem = lift2 I.rem - let lt = lift2_cmp I.lt - let gt = lift2_cmp I.gt - let le = lift2_cmp I.le - let ge = lift2_cmp I.ge - let eq = lift2_cmp I.eq - let ne = lift2_cmp I.ne - let lognot = lift I.lognot - let logand = lift2 I.logand - let logor = lift2 I.logor - let logxor = lift2 I.logxor - let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) - let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) - let c_lognot = lift_logical I.c_lognot - let c_logand = lift2 I.c_logand - let c_logor = lift2 I.c_logor - - let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} - - let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v - - let relift x = { v = I.relift x.v; ikind = x.ikind } - - let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } -end - -module type Ikind = -sig - val ikind: unit -> Cil.ikind -end - -module PtrDiffIkind : Ikind = -struct - let ikind = Cilfacade.ptrdiff_ikind -end - -module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = -struct - include I - let top () = I.top_of (Ik.ikind ()) - let bot () = I.bot_of (Ik.ikind ()) -end - -module Size = struct (* size in bits as int, range as int64 *) - open Cil - let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned - - let top_typ = TInt (ILongLong, []) - let min_for x = intKindForValue x (sign x = `Unsigned) - let bit = function (* bits needed for representation *) - | IBool -> 1 - | ik -> bytesSizeOfInt ik * 8 - let is_int64_big_int x = Z.fits_int64 x - let card ik = (* cardinality *) - let b = bit ik in - Z.shift_left Z.one b - let bits ik = (* highest bits for neg/pos values *) - let s = bit ik in - if isSigned ik then s-1, s-1 else 0, s - let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) - let range ik = - let a,b = bits ik in - let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in - let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) - x,y - - let is_cast_injective ~from_type ~to_type = - let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in - let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in - if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; - Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 - - let cast t x = (* TODO: overflow is implementation-dependent! *) - if t = IBool then - (* C11 6.3.1.2 Boolean type *) - if Z.equal x Z.zero then Z.zero else Z.one - else - let a,b = range t in - let c = card t in - let y = Z.erem x c in - let y = if Z.gt y b then Z.sub y c - else if Z.lt y a then Z.add y c - else y - in - if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); - y - - let min_range_sign_agnostic x = - let size ik = - let a,b = bits_i64 ik in - Int64.neg a,b - in - if sign x = `Signed then - size (min_for x) - else - let a, b = size (min_for x) in - if b <= 64L then - let upper_bound_less = Int64.sub b 1L in - let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in - if x <= max_one_less then - a, upper_bound_less - else - a,b - else - a, b - - (* From the number of bits used to represent a positive value, determines the maximal representable value *) - let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) - - (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) - let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) - -end - - -module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct - open B - (* these should be overwritten for better precision if possible: *) - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let of_bitfield ik x = top_of ik - let starting ?(suppress_ovwarn=false) ik x = top_of ik - let ending ?(suppress_ovwarn=false) ik x = top_of ik - let maximal x = None - let minimal x = None -end - -module Std (B: sig - type t - val name: unit -> string - val top_of: Cil.ikind -> t - val bot_of: Cil.ikind -> t - val show: t -> string - val equal: t -> t -> bool - end) = struct - include Printable.StdLeaf - let name = B.name (* overwrite the one from Printable.Std *) - open B - let is_top x = failwith "is_top not implemented for IntDomain.Std" - let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind - This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) - let is_top_of ik x = B.equal x (top_of ik) - - (* all output is based on B.show *) - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) - let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y - - include StdTop (B) -end - -(* Textbook interval arithmetic, without any overflow handling etc. *) -module IntervalArith (Ints_t : IntOps.IntOps) = struct - let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) - let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) - - let mul (x1, x2) (y1, y2) = - let x1y1 = (Ints_t.mul x1 y1) in - let x1y2 = (Ints_t.mul x1 y2) in - let x2y1 = (Ints_t.mul x2 y1) in - let x2y2 = (Ints_t.mul x2 y2) in - (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) - - let shift_left (x1,x2) (y1,y2) = - let y1p = Ints_t.shift_left Ints_t.one y1 in - let y2p = Ints_t.shift_left Ints_t.one y2 in - mul (x1, x2) (y1p, y2p) - - let div (x1, x2) (y1, y2) = - let x1y1n = (Ints_t.div x1 y1) in - let x1y2n = (Ints_t.div x1 y2) in - let x2y1n = (Ints_t.div x2 y1) in - let x2y2n = (Ints_t.div x2 y2) in - let x1y1p = (Ints_t.div x1 y1) in - let x1y2p = (Ints_t.div x1 y2) in - let x2y1p = (Ints_t.div x2 y1) in - let x2y2p = (Ints_t.div x2 y2) in - (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) - - let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) - let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) - - let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) - - let one = (Ints_t.one, Ints_t.one) - let zero = (Ints_t.zero, Ints_t.zero) - let top_bool = (Ints_t.zero, Ints_t.one) - - let to_int (x1, x2) = - if Ints_t.equal x1 x2 then Some x1 else None - - let upper_threshold u max_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - let max_ik' = Ints_t.to_bigint max_ik in - let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in - BatOption.map_default Ints_t.of_bigint max_ik t - let lower_threshold l min_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - let min_ik' = Ints_t.to_bigint min_ik in - let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in - BatOption.map_default Ints_t.of_bigint min_ik t - let is_upper_threshold u = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - List.exists (Z.equal u) ts - let is_lower_threshold l = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - List.exists (Z.equal l) ts -end - -module IntInvariant = -struct - let of_int e ik x = - if get_bool "witness.invariant.exact" then - Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) - else - Invariant.none - - let of_incl_list e ik ps = - match ps with - | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> - assert (List.mem Z.zero ps); - assert (List.mem Z.one ps); - Invariant.none - | [_] when get_bool "witness.invariant.exact" -> - Invariant.none - | _ :: _ :: _ - | [_] | [] -> - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in - Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) (Invariant.bot ()) ps - - let of_interval_opt e ik = function - | (Some x1, Some x2) when Z.equal x1 x2 -> - of_int e ik x1 - | x1_opt, x2_opt -> - let (min_ik, max_ik) = Size.range ik in - let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in - let i1 = - match x1_opt, inexact_type_bounds with - | Some x1, false when Z.equal min_ik x1 -> Invariant.none - | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) - | None, _ -> Invariant.none - in - let i2 = - match x2_opt, inexact_type_bounds with - | Some x2, false when Z.equal x2 max_ik -> Invariant.none - | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) - | None, _ -> Invariant.none - in - Invariant.(i1 && i2) - - let of_interval e ik (x1, x2) = - of_interval_opt e ik (Some x1, Some x2) - - let of_excl_list e ik ns = - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in - Invariant.(a && i) - ) (Invariant.top ()) ns -end - -module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = -struct - let name () = "intervals" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - module IArith = IntervalArith (Ints_t) - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - let top_of ik = Some (range ik) - let bot () = None - let bot_of ik = bot () (* TODO: improve *) - - let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) -> - if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> - if Ints_t.compare x y > 0 then - (None,{underflow=false; overflow=false}) - else ( - let (min_ik, max_ik) = range ik in - let underflow = Ints_t.compare min_ik x > 0 in - let overflow = Ints_t.compare max_ik y < 0 in - let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in - let v = - if underflow || overflow then - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in - let resdiff = Ints_t.abs (Ints_t.sub y x) in - if Ints_t.compare resdiff diff > 0 then - top_of ik - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if Ints_t.compare l u <= 0 then - Some (l, u) - else - (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) - top_of ik - else if not cast && should_ignore_overflow ik then - let tl, tu = BatOption.get @@ top_of ik in - Some (Ints_t.max tl x, Ints_t.min tu y) - else - top_of ik - else - Some (x,y) - in - (v, ov_info) - ) - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst - - let meet ik (x:t) y = - match x, y with - | None, z | z, None -> None - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst - - (* TODO: change to_int signature so it returns a big_int *) - let to_int x = Option.bind x (IArith.to_int) - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) - let of_bitfield ik x = - let min ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in - let isNegative = Ints_t.logand signBit o <> Ints_t.zero in - if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) - else Ints_t.lognot z - in let max ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.of_bigint (snd (Size.range ik)) in - let isPositive = Ints_t.logand signBit z <> Ints_t.zero in - if isSigned ik && isPositive then Ints_t.logand signMask o - else o - in fst (norm ik (Some (min ik x, max ik x))) - let of_int ik (x: int_t) = of_interval ik (x,x) - let zero = Some IArith.zero - let one = Some IArith.one - let top_bool = Some IArith.top_bool - - let to_bitfield ik z = - match z with None -> (Ints_t.lognot Ints_t.zero, Ints_t.lognot Ints_t.zero) | Some (x,y) -> - let (min_ik, max_ik) = Size.range ik in - let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in - let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in - - let rec analyze_bits pos (acc_z, acc_o) = - if pos < 0 then (acc_z, acc_o) - else - let position = Ints_t.shift_left Ints_t.one pos in - let mask = Ints_t.sub position Ints_t.one in - let remainder = Ints_t.logand startv mask in - - let without_remainder = Ints_t.sub startv remainder in - let bigger_number = Ints_t.add without_remainder position in - - let bit_status = - if Ints_t.compare bigger_number endv <= 0 then - `top - else - if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then - `one - else - `zero - in - - let new_acc = - match bit_status with - | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) - | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) - | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) - - in - analyze_bits (pos - 1) new_acc - in - let result = analyze_bits (Size.bit ik - 1) (Ints_t.zero, Ints_t.zero) in - let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) - in casted - - let of_bool _ik = function true -> one | false -> zero - let to_bool (a: t) = match a with - | None -> None - | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) - - (* TODO: change signature of maximal, minimal to return big_int*) - let maximal = function None -> None | Some (x,y) -> Some y - let minimal = function None -> None | Some (x,y) -> Some x - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) - - let widen ik x y = - match x, y with - | None, z | z, None -> z - | Some (l0,u0), Some (l1,u1) -> - let (min_ik, max_ik) = range ik in - let threshold = get_interval_threshold_widening () in - let l2 = - if Ints_t.compare l0 l1 = 0 then l0 - else if threshold then IArith.lower_threshold l1 min_ik - else min_ik - in - let u2 = - if Ints_t.compare u0 u1 = 0 then u0 - else if threshold then IArith.upper_threshold u1 max_ik - else max_ik - in - norm ik @@ Some (l2,u2) |> fst - let widen ik x y = - let r = widen ik x y in - if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; - assert (leq x y); (* TODO: remove for performance reasons? *) - r - - let narrow ik x y = - match x, y with - | _,None | None, _ -> None - | Some (x1,x2), Some (y1,y2) -> - let threshold = get_interval_threshold_widening () in - let (min_ik, max_ik) = range ik in - let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in - let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in - norm ik @@ Some (lr,ur) |> fst - - - let narrow ik x y = - if get_interval_narrow_by_meet () then - meet ik x y - else - narrow ik x y - - let log f ~annihilator ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, _ when x = annihilator -> of_bool ik annihilator - | _, Some y when y = annihilator -> of_bool ik annihilator - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) ~annihilator:true - let c_logand = log (&&) ~annihilator:false - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let bit f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - let bitcomp f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let logxor = bit (fun _ik -> Ints_t.logxor) - - let logand ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) - | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst - | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst - | _ -> top_of ik - - let logor = bit (fun _ik -> Ints_t.logor) - - let bit1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_int i1 with - | Some x -> of_int ik (f ik x) |> fst - | _ -> top_of ik - - let lognot = bit1 (fun _ik -> Ints_t.lognot) - let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) - - let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) - - let binary_op_with_norm ?no_ov op ik x y = match x, y with - | None, None -> (None, {overflow=false; underflow= false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some x, Some y -> norm ik @@ Some (op x y) - - let add ?no_ov = binary_op_with_norm IArith.add - let mul ?no_ov = binary_op_with_norm IArith.mul - let sub ?no_ov = binary_op_with_norm IArith.sub - - let shift_left ik a b = - match is_bot a, is_bot b with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) - | _ -> - match a, minimal b, maximal b with - | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> - (try - let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in - norm ik @@ Some r - with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let rem ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (xl, xu), Some (yl, yu) -> - if is_top_of ik x && is_top_of ik y then - (* This is needed to preserve soundness also on things bigger than int32 e.g. *) - (* x: 3803957176L -> T in Interval32 *) - (* y: 4209861404L -> T in Interval32 *) - (* x % y: 3803957176L -> T in Interval32 *) - (* T in Interval32 is [-2147483648,2147483647] *) - (* the code below computes [-2147483647,2147483647] for this though which is unsound *) - top_of ik - else - (* If we have definite values, Ints_t.rem will give a definite result. - * Otherwise we meet with a [range] the result can be in. - * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. - * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) - let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in - let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in - let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range - - let rec div ?no_ov ik x y = - match x, y with - | None, None -> (bot (),{underflow=false; overflow=false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | (Some (x1,x2) as x), (Some (y1,y2) as y) -> - begin - let is_zero v = Ints_t.compare v Ints_t.zero = 0 in - match y1, y2 with - | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) - | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) - | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) - | _ -> binary_op_with_norm IArith.div ik x y - end - - let ne ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik true - else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then - of_bool ik false - else top_bool - - let eq ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then - of_bool ik true - else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik false - else top_bool - - let ge ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 then of_bool ik true - else if Ints_t.compare x2 y1 < 0 then of_bool ik false - else top_bool - - let le ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 <= 0 then of_bool ik true - else if Ints_t.compare y2 x1 < 0 then of_bool ik false - else top_bool - - let gt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 then of_bool ik true - else if Ints_t.compare x2 y1 <= 0 then of_bool ik false - else top_bool - - let lt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 < 0 then of_bool ik true - else if Ints_t.compare y2 x1 <= 0 then of_bool ik false - else top_bool - - let invariant_ikind e ik = function - | Some (x1, x2) -> - let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in - IntInvariant.of_interval e ik (x1', x2') - | None -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink = function - | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) - | None -> empty - in - QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) - - let modulo n k = - let result = Ints_t.rem n k in - if Ints_t.compare result Ints_t.zero >= 0 then result - else Ints_t.add result k - - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None - else if Ints_t.equal m Ints_t.zero then - Some (c, c) - else - let (min_ik, max_ik) = range ik in - let rcx = - if Ints_t.equal x min_ik then x else - Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in - let lcy = - if Ints_t.equal y max_ik then y else - Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in - if Ints_t.compare rcx lcy > 0 then None - else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst - else norm ik @@ Some (rcx, lcy) |> fst - | _ -> None - - let refine_with_congruence ik x y = - let refn = refine_with_congruence ik x y in - if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; - refn - - let refine_with_interval ik a b = meet ik a b - - let refine_with_bitfield ik a b = - let interv = of_bitfield ik b in - meet ik a interv - - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - match intv, excl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls, (rl, rh)) -> - let rec shrink op b = - let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in - if not (Ints_t.equal b new_b) then shrink op new_b else new_b - in - let (min_ik, max_ik) = range ik in - let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in - let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in - let intv' = norm ik @@ Some (l', u') |> fst in - let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in - meet ik intv' range - - let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = - match intv, incl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls) -> - let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in - let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in - match min None ls, max None ls with - | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) - | _, _-> intv - - let project ik p t = t -end - -module InfixIntOps (Ints_t : IntOps.IntOps) = struct - let (&:) = Ints_t.logand - let (|:) = Ints_t.logor - let (^:) = Ints_t.logxor - let (!:) = Ints_t.lognot - let (<<:) = Ints_t.shift_left - let (>>:) = Ints_t.shift_right - let (<:) = fun a b -> Ints_t.compare a b < 0 - let (=:) = fun a b -> Ints_t.compare a b = 0 - let (>:) = fun a b -> Ints_t.compare a b > 0 - - let (+:) = Ints_t.add - let (-:) = Ints_t.sub - let ( *: ) = Ints_t.mul - let (/:) = Ints_t.div - let (%:) = Ints_t.rem - - let (>>.) = fun a b -> a >>: b |: !:((Ints_t.one <<: b) -: Ints_t.one) -end - -(* - Operations in the abstract domain mostly based on - - "Abstract Domains for Bit-Level Machine Integer and Floating-point Operations" - of Antoine Miné - https://doi.org/10.29007/b63g - - and - - the bachelor thesis "Integer Abstract Domains" - of Tomáš Brukner - https://is.muni.cz/th/kasap/thesis.pdf -*) - -(* Bitfield arithmetic, without any overflow handling etc. *) -module BitfieldArith (Ints_t : IntOps.IntOps) = struct - - include InfixIntOps (Ints_t) - - let zero_mask = Ints_t.zero - let one_mask = !:zero_mask - - let of_int x = (!:x, x) - - let join (z1,o1) (z2,o2) = (z1 |: z2, o1 |: o2) - let meet (z1,o1) (z2,o2) = (z1 &: z2, o1 &: o2) - - let one = of_int Ints_t.one - let zero = of_int Ints_t.zero - let top_bool = join one zero - - let bits_known (z,o) = z ^: o - let bits_unknown (z,o) = z &: o - let bits_set bf = (snd bf) &: (bits_known bf) - let bits_invalid (z,o) = !:(z |: o) - - let is_const (z,o) = (z ^: o) =: one_mask - - let is_invalid (z,o) = - not (!:(z |: o) = Ints_t.zero) - - let nabla x y= if x =: (x |: y) then x else one_mask - - let widen (z1,o1) (z2,o2) = (nabla z1 z2, nabla o1 o2) - - let lognot (z,o) = (o,z) - - let logxor (z1,o1) (z2,o2) = ((z1 &: z2) |: (o1 &: o2), - (z1 &: o2) |: (o1 &: z2)) - - let logand (z1,o1) (z2,o2) = (z1 |: z2, o1 &: o2) - - let logor (z1,o1) (z2,o2) = (z1 &: z2, o1 |: o2) - - let bitmask_up_to pos = - let top_bit = Ints_t.one <<: pos in - if top_bit =: Ints_t.zero - then Ints_t.zero - else - Ints_t.sub top_bit Ints_t.one - - let get_bit bf pos = Ints_t.one &: (bf >>: pos) - - let min ik (z,o) = - let signBit = Ints_t.one <<: ((Size.bit ik) - 1) in - let signMask = !: (Ints_t.of_bigint (snd (Size.range ik))) in - let isNegative = signBit &: o <> Ints_t.zero in - if isSigned ik && isNegative then Ints_t.to_bigint(signMask |: (!: z)) - else Ints_t.to_bigint(!: z) - - let max ik (z,o) = - let signBit = Ints_t.one <<: ((Size.bit ik) - 1) in - let signMask = Ints_t.of_bigint (snd (Size.range ik)) in - let isPositive = signBit &: z <> Ints_t.zero in - if isSigned ik && isPositive then Ints_t.to_bigint(signMask &: o) - else Ints_t.to_bigint o - - let rec concretize (z,o) = - if is_const (z,o) then [o] - else - let is_bit_unknown = not ((bits_unknown (z,o) &: Ints_t.one) =: Ints_t.zero) in - let bit = o &: Ints_t.one in - concretize (z >>. 1, o >>: 1) |> - if is_bit_unknown then - List.concat_map (fun c -> [c <<: 1; (c <<: 1) |: Ints_t.one]) - else - List.map (fun c -> c <<: 1 |: bit) - - let concretize bf = List.map Ints_t.to_int (concretize bf) - - let shift_right ik (z,o) c = - let sign_mask = !:(bitmask_up_to (Size.bit ik - c)) in - if isSigned ik && o <: Ints_t.zero then - (z >>: c, (o >>: c) |: sign_mask) - else - ((z >>: c) |: sign_mask, o >>: c) - - let shift_right ik (z1, o1) (z2, o2) = - if is_const (z2, o2) - then - shift_right ik (z1, o1) (Ints_t.to_int o2) - else - let shift_counts = concretize (z2, o2) in - List.fold_left (fun acc c -> - let next = shift_right ik (z1, o1) c in join acc next - ) (zero_mask, zero_mask) shift_counts - - let shift_left _ (z,o) c = - let zero_mask = bitmask_up_to c in - ((z <<: c) |: zero_mask, o <<: c) - - let shift_left ik (z1, o1) (z2, o2) = - if is_const (z2, o2) - then - shift_left ik (z1, o1) (Ints_t.to_int o2) - else - let shift_counts = concretize (z2, o2) in - List.fold_left (fun acc c -> - let next = shift_left ik (z1, o1) c in join acc next - ) (zero_mask, zero_mask) shift_counts - -end - -module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct - - include InfixIntOps (Ints_t) - - let name () = "bitfield" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) [@@deriving eq, ord, hash] - - module BArith = BitfieldArith (Ints_t) - - let top () = (BArith.one_mask, BArith.one_mask) - let bot () = (BArith.zero_mask, BArith.zero_mask) - let top_of ik = - if isSigned ik then top () - else (BArith.one_mask, Ints_t.of_bigint (snd (Size.range ik))) - let bot_of ik = bot () - - let to_pretty_bits (z,o) = - let known_bitmask = ref (BArith.bits_known (z,o)) in - let invalid_bitmask = ref (BArith.bits_invalid (z,o)) in - let o_mask = ref o in - let z_mask = ref z in - - let rec to_pretty_bits' acc = - let current_bit_known = (!known_bitmask &: Ints_t.one) = Ints_t.one in - let current_bit_impossible = (!invalid_bitmask &: Ints_t.one) = Ints_t.one in - - let bit_value = !o_mask &: Ints_t.one in - let bit = - if current_bit_impossible then "⊥" - else if not current_bit_known then "⊤" - else Ints_t.to_string bit_value - in - - if (!o_mask = Ints_t.of_int (-1) || !o_mask = Ints_t.zero ) && (!z_mask = Ints_t.of_int (-1) || !z_mask = Ints_t.zero) then - let prefix = bit ^ "..." ^ bit in - prefix ^ acc - else - (known_bitmask := !known_bitmask >>: 1; - invalid_bitmask := !invalid_bitmask >>: 1; - o_mask := !o_mask >>: 1; - z_mask := !z_mask >>: 1; - to_pretty_bits' (bit ^ acc)) - in - "0b" ^ to_pretty_bits' "" - - let show t = - if t = bot () then "bot" else - if t = top () then "top" else - let (z,o) = t in - Format.sprintf "{%s, (zs:%s, os:%s)}" (to_pretty_bits t) (Ints_t.to_string z) (Ints_t.to_string o) - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let range ik bf = (BArith.min ik bf, BArith.max ik bf) - - let maximal (z,o) = - if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some o - else None - - let minimal (z,o) = - if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some (!:z) - else None - - let wrap ik (z,o) = - let (min_ik, max_ik) = Size.range ik in - if isSigned ik then - let newz = (z &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit z (Size.bit ik - 1))) in - let newo = (o &: (Ints_t.of_bigint max_ik)) |: ((Ints_t.of_bigint min_ik) *: (BArith.get_bit o (Size.bit ik - 1))) in - (newz,newo) - else - let newz = z |: !:(Ints_t.of_bigint max_ik) in - let newo = o &: (Ints_t.of_bigint max_ik) in - (newz,newo) - - let norm ?(suppress_ovwarn=false) ik (z,o) = - if BArith.is_invalid (z,o) then - (bot (), {underflow=false; overflow=false}) - else - let (min_ik, max_ik) = Size.range ik in - let isPos = z < Ints_t.zero in - let isNeg = o < Ints_t.zero in - let underflow = if isSigned ik then (((Ints_t.of_bigint min_ik) &: z) <> Ints_t.zero) && isNeg else isNeg in - - let overflow = (((!: (Ints_t.of_bigint max_ik)) &: o) <> Ints_t.zero) && isPos in - let new_bitfield = wrap ik (z,o) - in - let overflow_info = if suppress_ovwarn then {underflow=false; overflow=false} else {underflow=underflow; overflow=overflow} in - if not (underflow || overflow) then - ((z,o), overflow_info) - else if should_wrap ik then - (new_bitfield, overflow_info) - else if should_ignore_overflow ik then - (M.warn ~category:M.Category.Integer.overflow "Bitfield: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Top"; - (* (bot (), overflow_info)) *) - (top_of ik, overflow_info)) - else - (top (), overflow_info) - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t - - let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst - - let meet ik x y = (norm ik @@ (BArith.meet x y)) |> fst - - let leq (x:t) (y:t) = (BArith.join x y) = y - - let widen ik x y = (norm ik @@ BArith.widen x y) |> fst - - let narrow ik x y = meet ik x y - - let of_int ik (x: int_t) = (norm ik @@ BArith.of_int x) - - let to_int (z,o) = if is_bot (z,o) then None else - if BArith.is_const (z,o) then Some o - else None - - let equal_to i bf = - if BArith.of_int i = bf then `Eq - else if leq (BArith.of_int i) bf then `Top - else `Neq - - (* Conversions *) - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - let (min_ik, max_ik) = Size.range ik in - let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in - let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in - - let rec analyze_bits pos (acc_z, acc_o) = - if pos < 0 then (acc_z, acc_o) - else - let position = Ints_t.shift_left Ints_t.one pos in - let mask = Ints_t.sub position Ints_t.one in - let remainder = Ints_t.logand startv mask in - - let without_remainder = Ints_t.sub startv remainder in - let bigger_number = Ints_t.add without_remainder position in - - let bit_status = - if Ints_t.compare bigger_number endv <= 0 then - `top - else - if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then - `one - else - `zero - in - - let new_acc = - match bit_status with - | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) - | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) - | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) - - in - analyze_bits (pos - 1) new_acc - in - let result = analyze_bits (Size.bit ik - 1) (bot()) in - let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) - in (wrap ik casted, {underflow=false; overflow=false}) - - let of_bool _ik = function true -> BArith.one | false -> BArith.zero - - let to_bool d = - if not (leq BArith.zero d) then Some true - else if d = BArith.zero then Some false - else None - - let of_bitfield ik x = norm ik x |> fst - - let to_bitfield ik x = norm ik x |> fst - - let is_power_of_two x = (x &: (x -: Ints_t.one) = Ints_t.zero) - - let of_congruence ik (c,m) = - if m = Ints_t.zero then of_int ik c |> fst - else if is_power_of_two m then - let mod_mask = m -: Ints_t.one in - let z = !: c in - let o = !:mod_mask |: c in - norm ik (z,o) |> fst - else top_of ik - - (* Logic *) - - let log1 f ik i1 = match to_bool i1 with - | None -> top_of ik - | Some x -> of_bool ik (f x) - - let log2 f ~annihilator ik i1 i2 = match to_bool i1, to_bool i2 with - | Some x, _ when x = annihilator -> of_bool ik annihilator - | _, Some y when y = annihilator -> of_bool ik annihilator - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log2 (||) ~annihilator:true - - let c_logand = log2 (&&) ~annihilator:false - - let c_lognot ik i1 = log1 not ik i1 - - - (* Bitwise *) - - let logxor ik i1 i2 = BArith.logxor i1 i2 |> norm ik |> fst - - let logand ik i1 i2 = BArith.logand i1 i2 |> norm ik |> fst - - let logor ik i1 i2 = BArith.logor i1 i2 |> norm ik |> fst - - let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst - - let precision ik = snd @@ Size.bits ik - let exclude_undefined_bitshifts ik (z,o) = - let mask = BArith.bitmask_up_to (Z.log2up @@ Z.of_int @@ precision ik) in - (z |: !:mask, o &: mask) - - let is_invalid_shift_operation ik a b = BArith.is_invalid b - || BArith.is_invalid a - - let is_undefined_shift_operation ik a b = - let some_negatives = BArith.min ik b < Z.zero in - let b_is_geq_precision = Z.to_int @@ BArith.min ik b >= precision ik in - (isSigned ik) && (some_negatives || b_is_geq_precision) && not (a = BArith.zero) - - let shift_right ik a b = - if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; - if is_invalid_shift_operation ik a b - then - (bot (), {underflow=false; overflow=false}) - else if is_undefined_shift_operation ik a b - then - (top (), {underflow=false; overflow=false}) - else - norm ik @@ BArith.shift_right ik a (exclude_undefined_bitshifts ik b) - - let shift_left ik a b = - if M.tracing then M.trace "bitfield" "%a << %a" pretty a pretty b; - if is_invalid_shift_operation ik a b - then - (bot (), {underflow=false; overflow=false}) - else if is_undefined_shift_operation ik a b - then - (top (), {underflow=false; overflow=false}) - else - norm ik @@ BArith.shift_left ik a (exclude_undefined_bitshifts ik b) - - (* Arith *) - - (* - add, sub and mul based on the paper - "Sound, Precise, and Fast Abstract Interpretation with Tristate Numbers" - of Vishwanathan et al. - https://doi.org/10.1109/CGO53902.2022.9741267 - *) - - let add_paper pv pm qv qm = - let sv = pv +: qv in - let sm = pm +: qm in - let sigma = sv +: sm in - let chi = sigma ^: sv in - let mu = pm |: qm |: chi in - let rv = sv &: !:mu in - let rm = mu in - (rv, rm) - - let add ?no_ov ik (z1, o1) (z2, o2) = - let pv = o1 &: !:z1 in - let pm = o1 &: z1 in - let qv = o2 &: !:z2 in - let qm = o2 &: z2 in - let (rv, rm) = add_paper pv pm qv qm in - let o3 = rv |: rm in - let z3 = !:rv |: rm in - norm ik (z3,o3) - - let sub ?no_ov ik (z1, o1) (z2, o2) = - let pv = o1 &: !:z1 in - let pm = o1 &: z1 in - let qv = o2 &: !:z2 in - let qm = o2 &: z2 in - let dv = pv -: qv in - let alpha = dv +: pm in - let beta = dv -: qm in - let chi = alpha ^: beta in - let mu = pm |: qm |: chi in - let rv = dv &: !:mu in - let rm = mu in - let o3 = rv |: rm in - let z3 = !:rv |: rm in - norm ik (z3, o3) - - let neg ?no_ov ik x = - M.trace "bitfield" "neg"; - sub ?no_ov ik BArith.zero x - - let mul ?no_ov ik (z1, o1) (z2, o2) = - let pm = ref (z1 &: o1) in - let pv = ref (o1 &: !:z1) in - let qm = ref (z2 &: o2) in - let qv = ref (o2 &: !:z2) in - let accv = ref BArith.zero_mask in - let accm = ref BArith.zero_mask in - let size = if isSigned ik then Size.bit ik - 1 else Size.bit ik in - let bitmask = Ints_t.of_bigint (fst (Size.range ik)) in - let signBitUndef1 = z1 &: o1 &: bitmask in - let signBitUndef2 = z2 &: o2 &: bitmask in - let signBitUndef = signBitUndef1 |: signBitUndef2 in - let signBitDefO = (o1 ^: o2) &: bitmask in - let signBitDefZ = !:(o1 ^: o2) &: bitmask in - for _ = size downto 0 do - (if !pm &: Ints_t.one == Ints_t.one then - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (!qv |: !qm)) - else if !pv &: Ints_t.one == Ints_t.one then - accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); - - pv := !pv >>: 1; - pm := !pm >>: 1; - qv := !qv <<: 1; - qm := !qm <<: 1; - done; - let (rv, rm) = add_paper !accv Ints_t.zero Ints_t.zero !accm in - let o3 = ref(rv |: rm) in - let z3 = ref(!:rv |: rm) in - if isSigned ik then z3 := signBitUndef |: signBitDefZ |: !z3; - if isSigned ik then o3 := signBitUndef |: signBitDefO |: !o3; - norm ik (!z3, !o3) - - let div ?no_ov ik (z1, o1) (z2, o2) = - let res = if BArith.is_const (z1, o1) && BArith.is_const (z2, o2) then (let tmp = o1 /: o2 in (!:tmp, tmp)) - else if BArith.is_const (z2, o2) && is_power_of_two o2 then (z1 >>: (Ints_t.to_int o2), o1 >>: (Ints_t.to_int o2)) - else top_of ik in - norm ik res - - let rem ik x y = - if BArith.is_const x && BArith.is_const y then ( - let def_x = Option.get (to_int x) in - let def_y = Option.get (to_int y) in - fst (of_int ik (Ints_t.rem def_x def_y)) - ) - else if BArith.is_const y && is_power_of_two (snd y) then ( - let mask = Ints_t.sub (snd y) Ints_t.one in - let newz = Ints_t.logor (fst x) (Ints_t.lognot mask) in - let newo = Ints_t.logand (snd x) mask in - norm ik (newz, newo) |> fst - ) - else top_of ik - - let eq ik x y = - if (BArith.max ik x) <= (BArith.min ik y) && (BArith.min ik x) >= (BArith.max ik y) then of_bool ik true - else if (BArith.min ik x) > (BArith.max ik y) || (BArith.max ik x) < (BArith.min ik y) then of_bool ik false - else BArith.top_bool - - let ne ik x y = match eq ik x y with - | t when t = of_bool ik true -> of_bool ik false - | t when t = of_bool ik false -> of_bool ik true - | _ -> BArith.top_bool - - let le ik x y = - if (BArith.max ik x) <= (BArith.min ik y) then of_bool ik true - else if (BArith.min ik x) > (BArith.max ik y) then of_bool ik false - else BArith.top_bool - - let ge ik x y = le ik y x - - let lt ik x y = if (BArith.max ik x) < (BArith.min ik y) then of_bool ik true - else if (BArith.min ik x) >= (BArith.max ik y) then of_bool ik false - else BArith.top_bool - - let gt ik x y = lt ik y x - - (* Invariant *) - - let invariant_ikind e ik (z,o) = - let range = range ik (z,o) in - IntInvariant.of_interval e ik range - - let starting ?(suppress_ovwarn=false) ik n = - let (min_ik, max_ik) = Size.range ik in - of_interval ~suppress_ovwarn ik (n, Ints_t.of_bigint max_ik) - - let ending ?(suppress_ovwarn=false) ik n = - let (min_ik, max_ik) = Size.range ik in - of_interval ~suppress_ovwarn ik (Ints_t.of_bigint min_ik, n) - - (* Refinements *) - - let refine_with_congruence ik bf ((cong) : (int_t * int_t ) option) : t = - match bf, cong with - | (z,o), Some (c, m) when m = Ints_t.zero -> norm ik (!: c, c) |> fst - | (z,o), Some (c, m) when is_power_of_two m && m <> Ints_t.one -> - let congruenceMask = !:m in - let newz = (!:congruenceMask &: z) |: (congruenceMask &: !:c) in - let newo = (!:congruenceMask &: o) |: (congruenceMask &: c) in - norm ik (newz, newo) |> fst - | _ -> norm ik bf |> fst - - let refine_with_interval ik t itv = - match itv with - | None -> norm ik t |> fst - | Some (l, u) -> meet ik t (of_interval ik (l, u) |> fst) - - let refine_with_bitfield ik x y = meet ik x y - - let refine_with_excl_list ik t (excl : (int_t list * (int64 * int64)) option) : t = norm ik t |> fst - - let refine_with_incl_list ik t (incl : (int_t list) option) : t = - let joined =match incl with - | None -> top_of ik - | Some ls -> - List.fold_left (fun acc i -> BArith.join acc (BArith.of_int i)) (bot_of ik) ls - in - meet ik t joined - - - (* Unit Tests *) - - let arbitrary ik = - let open QCheck.Iter in - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink (z, o) = - (GobQCheck.shrink pair_arb (z, o) - >|= (fun (new_z, new_o) -> - (* Randomly flip bits to be opposite *) - let random_mask = Ints_t.of_int64 (Random.int64 (Int64.of_int (Size.bits ik |> snd))) in - let unsure_bitmask= new_z &: new_o in - let canceled_bits= unsure_bitmask &: random_mask in - let flipped_z = new_z |: canceled_bits in - let flipped_o = new_o &: !:canceled_bits in - norm ik (flipped_z, flipped_o) |> fst - )) - in - QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (i1,i2) |> fst ) pair_arb) - - let project ik p t = t - -end - - -(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) -module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = -struct - - module Interval = IntervalFunctor (Ints_t) - module IArith = IntervalArith (Ints_t) - - - let name () = "interval_sets" - - type int_t = Ints_t.t - - let (>.) a b = Ints_t.compare a b > 0 - let (=.) a b = Ints_t.compare a b = 0 - let (<.) a b = Ints_t.compare a b < 0 - let (>=.) a b = Ints_t.compare a b >= 0 - let (<=.) a b = Ints_t.compare a b <= 0 - let (+.) a b = Ints_t.add a b - let (-.) a b = Ints_t.sub a b - - (* - Each domain's element is guaranteed to be in canonical form. That is, each interval contained - inside the set does not overlap with each other and they are not adjacent. - *) - type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - - let top_of ik = [range ik] - - let bot () = [] - - let bot_of ik = bot () - - let show (x: t) = - let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in - List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" - - (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) - type event = Enter of Ints_t.t | Exit of Ints_t.t - - let unbox_event = function Enter x -> x | Exit x -> x - - let cmp_events x y = - (* Deliberately comparing ints first => Cannot be derived *) - let res = Ints_t.compare (unbox_event x) (unbox_event y) in - if res <> 0 then res - else - begin - match (x, y) with - | (Enter _, Exit _) -> -1 - | (Exit _, Enter _) -> 1 - | (_, _) -> 0 - end - - let interval_set_to_events (xs: t) = - List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs - - let two_interval_sets_to_events (xs: t) (ys: t) = - let xs = interval_set_to_events xs in - let ys = interval_set_to_events ys in - List.merge cmp_events xs ys - - (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap - This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) - let combined_event_list lattice_op (xs:event list) = - let l = match lattice_op with `Join -> 1 | `Meet -> 2 in - let aux (interval_count, acc) = function - | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) - | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) - in - List.fold_left aux (0, []) xs |> snd |> List.rev - - let rec events_to_intervals = function - | [] -> [] - | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) - | _ -> failwith "Invalid events list" - - let remove_empty_gaps (xs: t) = - let aux acc (l, r) = match acc with - | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' - | _ -> (l, r)::acc - in - List.fold_left aux [] xs |> List.rev - - let canonize (xs: t) = - interval_set_to_events xs |> - List.sort cmp_events |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let unop (x: t) op = match x with - | [] -> [] - | _ -> canonize @@ List.concat_map op x - - let binop (x: t) (y: t) op : t = match x, y with - | [], _ -> [] - | _, [] -> [] - | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) - - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let minimal = function - | [] -> None - | (x, _)::_ -> Some x - - let maximal = function - | [] -> None - | xs -> Some (BatList.last xs |> snd) - - let equal_to_interval i (a, b) = - if a =. b && b =. i then - `Eq - else if a <=. i && i <=. b then - `Top - else - `Neq - - let equal_to i xs = match List.map (equal_to_interval i) xs with - | [] -> failwith "unsupported: equal_to with bottom" - | [`Eq] -> `Eq - | ys when List.for_all ((=) `Neq) ys -> `Neq - | _ -> `Top - - let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = - if x >. y then - ([],{underflow=false; overflow=false}) - else - let (min_ik, max_ik) = range ik in - let underflow = min_ik >. x in - let overflow = max_ik <. y in - let v = if underflow || overflow then - begin - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (max_ik -. min_ik) in - let resdiff = Ints_t.abs (y -. x) in - if resdiff >. diff then - [range ik] - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if l <=. u then - [(l, u)] - else - (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) - [(min_ik, u); (l, max_ik)] - else if not cast && should_ignore_overflow ik then - [Ints_t.max min_ik x, Ints_t.min max_ik y] - else - [range ik] - end - else - [(x,y)] - in - if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) - - let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = - let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) - - let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> - let res = List.map op (BatList.cartesian_product x y) in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let unary_op_with_norm op (ik:ikind) (x: t) = match x with - | [] -> ([],{overflow=false; underflow=false}) - | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x - - let rec leq (xs: t) (ys: t) = - let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in - match xs, ys with - | [], _ -> true - | _, [] -> false - | (xl,xr)::xs', (yl,yr)::ys' -> - if leq_interval (xl,xr) (yl,yr) then - leq xs' ys - else if xr <. yl then - false - else - leq xs ys' - - let join ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let meet ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Meet |> - events_to_intervals - - let to_int = function - | [x] -> IArith.to_int x - | _ -> None - - let zero = [IArith.zero] - let one = [IArith.one] - let top_bool = [IArith.top_bool] - - let not_bool (x:t) = - let is_false x = equal x zero in - let is_true x = equal x one in - if is_true x then zero else if is_false x then one else top_bool - - let to_bool = function - | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false - | x -> if leq zero x then None else Some true - - let of_bool _ = function true -> one | false -> zero - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) - - let of_bitfield ik x = - let min ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.lognot (Ints_t.of_bigint (snd (Size.range ik))) in - let isNegative = Ints_t.logand signBit o <> Ints_t.zero in - if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) - else Ints_t.lognot z - in let max ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.of_bigint (snd (Size.range ik)) in - let isPositive = Ints_t.logand signBit z <> Ints_t.zero in - if isSigned ik && isPositive then Ints_t.logand signMask o - else o - in fst (norm_interval ik (min ik x, max ik x)) - - let to_bitfield ik x = - let joinbf (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) in - let rec from_list is acc = match is with - [] -> acc | - j::js -> from_list js (joinbf acc (Interval.to_bitfield ik (Some j))) - in from_list x (Ints_t.zero, Ints_t.zero) - - let of_int ik (x: int_t) = of_interval ik (x, x) - - let lt ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <. min_y then - of_bool ik true - else if min_x >=. max_y then - of_bool ik false - else - top_bool - - let le ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <=. min_y then - of_bool ik true - else if min_x >. max_y then - of_bool ik false - else - top_bool - - let gt ik x y = not_bool @@ le ik x y - - let ge ik x y = not_bool @@ lt ik x y - - let eq ik x y = match x, y with - | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> - one - | _ -> - if is_bot (meet ik x y) then - zero - else - top_bool - - let ne ik x y = not_bool @@ eq ik x y - let interval_to_int i = Interval.to_int (Some i) - let interval_to_bool i = Interval.to_bool (Some i) - - let log f ik (i1, i2) = - match (interval_to_bool i1, interval_to_bool i2) with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - - let bit f ik (i1, i2) = - match (interval_to_int i1), (interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - - let bitcomp f ik (i1, i2) = - match (interval_to_int i1, interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) - | _, _ -> (top_of ik,{overflow=false; underflow=false}) - - let logand ik x y = - let interval_logand = bit Ints_t.logand ik in - binop x y interval_logand - - let logor ik x y = - let interval_logor = bit Ints_t.logor ik in - binop x y interval_logor - - let logxor ik x y = - let interval_logxor = bit Ints_t.logxor ik in - binop x y interval_logxor - - let lognot ik x = - let interval_lognot i = - match interval_to_int i with - | Some x -> of_int ik (Ints_t.lognot x) |> fst - | _ -> top_of ik - in - unop x interval_lognot - - let shift_left ik x y = - let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftleft - - let shift_right ik x y = - let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftright - - let c_lognot ik x = - let log1 f ik i1 = - match interval_to_bool i1 with - | Some x -> of_bool ik (f x) - | _ -> top_of ik - in - let interval_lognot = log1 not ik in - unop x interval_lognot - - let c_logand ik x y = - let interval_logand = log (&&) ik in - binop x y interval_logand - - let c_logor ik x y = - let interval_logor = log (||) ik in - binop x y interval_logor - - let add ?no_ov = binary_op_with_norm IArith.add - let sub ?no_ov = binary_op_with_norm IArith.sub - let mul ?no_ov = binary_op_with_norm IArith.mul - let neg ?no_ov = unary_op_with_norm IArith.neg - - let div ?no_ov ik x y = - let rec interval_div x (y1, y2) = begin - let top_of ik = top_of ik |> List.hd in - let is_zero v = v =. Ints_t.zero in - match y1, y2 with - | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) - | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) - | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik - | _ -> IArith.div x (y1, y2) - end - in binary_op_with_norm interval_div ik x y - - let rem ik x y = - let interval_rem (x, y) = - if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then - top_of ik - else - let (xl, xu) = x in let (yl, yu) = y in - let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in - let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in - let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit Ints_t.rem ik (x, y)) [range] - in - binop x y interval_rem - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x - - (* - narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys - *) - let narrow ik xs ys = match xs ,ys with - | [], _ -> [] | _ ,[] -> xs - | _, _ -> - let min_xs = minimal xs |> Option.get in - let max_xs = maximal xs |> Option.get in - let min_ys = minimal ys |> Option.get in - let max_ys = maximal ys |> Option.get in - let min_range,max_range = range ik in - let threshold = get_interval_threshold_widening () in - let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in - let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in - xs - |> (function (_, y)::z -> (min, y)::z | _ -> []) - |> List.rev - |> (function (x, _)::z -> (x, max)::z | _ -> []) - |> List.rev - - (* - 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. - and joins all intervals in xs assigned to the same interval in ys as one interval. - 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. - 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) - - The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. - *) - let widen ik xs ys = - let (min_ik,max_ik) = range ik in - let threshold = get_bool "ana.int.interval_threshold_widening" in - let upper_threshold (_,u) = IArith.upper_threshold u max_ik in - let lower_threshold (l,_) = IArith.lower_threshold l min_ik in - (*obtain partitioning of xs intervals according to the ys interval that includes them*) - let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= - match xs,ys with - | _, [] -> [] - | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys - | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) - | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys - in - let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in - (*merge a pair of adjacent partitions*) - let merge_pair ik (a,b) (c,d) = - let new_a = function - | None -> Some (upper_threshold b, upper_threshold b) - | Some (ax,ay) -> Some (ax, upper_threshold b) - in - let new_c = function - | None -> Some (lower_threshold d, lower_threshold d) - | Some (cx,cy) -> Some (lower_threshold d, cy) - in - if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then - [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] - else - [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] - in - let partitions_are_approaching part_left part_right = match part_left, part_right with - | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) - | _,_ -> false - in - (*merge all approaching pairs of adjacent partitions*) - let rec merge_list ik = function - | [] -> [] - | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) - | x::xs -> x :: merge_list ik xs - in - (*expands left extremity*) - let widen_left = function - | [] -> [] - | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts - | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts - | x -> x - in - (*expands right extremity*) - let widen_right x = - let map_rightmost = function - | [] -> [] - | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts - | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts - | x -> x - in - List.rev x |> map_rightmost |> List.rev - in - interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd - - let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) - - let invariant_ikind e ik xs = - List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> - let open Invariant in List.fold_left (||) (bot ()) - - let modulo n k = - let result = Ints_t.rem n k in - if result >=. Ints_t.zero then result - else result +. k - - let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = - let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =. Ints_t.zero && (c <. x || c >. y) then [] - else if m =. Ints_t.zero then - [(c, c)] - else - let (min_ik, max_ik) = range ik in - let rcx = - if x =. min_ik then x else - x +. (modulo (c -. x) (Ints_t.abs m)) in - let lcy = - if y =. max_ik then y else - y -. (modulo (y -. c) (Ints_t.abs m)) in - if rcx >. lcy then [] - else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst - else norm_interval ik (rcx, lcy) |> fst - | _ -> [] - in - List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs - - let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] - - let refine_with_bitfield ik x y = - let interv = of_bitfield ik y in - meet ik x interv - - let refine_with_incl_list ik intvs = function - | None -> intvs - | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) - - let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = - let intv1 = (min, excl -. Ints_t.one) in - let intv2 = (excl +. Ints_t.one, max) in - norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst - - let of_excl_list ik (excls: int_t list) = - let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in - let res = List.fold_left (meet ik) (top_of ik) excl_list in - res - - let refine_with_excl_list ik (intv : t) = function - | None -> intv - | Some (xs, range) -> - let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = - excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl - in - let excl_list = List.map (excl_to_intervalset ik range) xs in - List.fold_left (meet ik) intv excl_list - - let project ik p t = t - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let list_pair_arb = QCheck.small_list pair_arb in - let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in - let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list - in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) -end - -module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct - include D - - let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = fst @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = fst @@ D.shift_left ik x y - - let shift_right ik x y = fst @@ D.shift_right ik x y -end - -module IntIkind = struct let ikind () = Cil.IInt end -module Interval = IntervalFunctor (IntOps.BigIntOps) -module Bitfield = BitfieldFunctor (IntOps.BigIntOps) -module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) -module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) -module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) -struct - include Printable.Std - let name () = "integers" - type t = Ints_t.t [@@deriving eq, ord, hash] - type int_t = Ints_t.t - let top () = raise Unknown - let bot () = raise Error - let top_of ik = top () - let bot_of ik = bot () - let show (x: Ints_t.t) = Ints_t.to_string x - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) - let is_top _ = false - let is_bot _ = false - - let equal_to i x = if i > x then `Neq else `Top - let leq x y = x <= y - let join x y = if Ints_t.compare x y > 0 then x else y - let widen = join - let meet x y = if Ints_t.compare x y > 0 then y else x - let narrow = meet - - let of_bool x = if x then Ints_t.one else Ints_t.zero - let to_bool' x = x <> Ints_t.zero - let to_bool x = Some (to_bool' x) - let of_int x = x - let to_int x = Some x - - let neg = Ints_t.neg - let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) - let sub = Ints_t.sub - let mul = Ints_t.mul - let div = Ints_t.div - let rem = Ints_t.rem - let lt n1 n2 = of_bool (n1 < n2) - let gt n1 n2 = of_bool (n1 > n2) - let le n1 n2 = of_bool (n1 <= n2) - let ge n1 n2 = of_bool (n1 >= n2) - let eq n1 n2 = of_bool (n1 = n2) - let ne n1 n2 = of_bool (n1 <> n2) - let lognot = Ints_t.lognot - let logand = Ints_t.logand - let logor = Ints_t.logor - let logxor = Ints_t.logxor - let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) - let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) - let c_lognot n1 = of_bool (not (to_bool' n1)) - let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) - let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) - let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." - let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) - let invariant _ _ = Invariant.none (* TODO *) -end - -module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) -struct - include Integers(IntOps.Int64Ops) - let top () = raise Unknown - let bot () = raise Error - let leq = equal - let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y - let join x y = if equal x y then x else top () - let meet x y = if equal x y then x else bot () -end - -module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) -struct - type int_t = Base.int_t - include Lattice.FlatConf (struct - include Printable.DefaultConf - let top_name = "Unknown int" - let bot_name = "Error int" - end) (Base) - - let top_of ik = top () - let bot_of ik = bot () - - - let name () = "flat integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let of_bitfield ik x = top_of ik - let starting ?(suppress_ovwarn=false) ikind x = top_of ikind - let ending ?(suppress_ovwarn=false) ikind x = top_of ikind - let maximal x = None - let minimal x = None - - let lift1 f x = match x with - | `Lifted x -> - (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> - (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) -struct - include Lattice.LiftPO (struct - include Printable.DefaultConf - let top_name = "MaxInt" - let bot_name = "MinInt" - end) (Base) - type int_t = Base.int_t - let top_of ik = top () - let bot_of ik = bot () - include StdTop (struct type nonrec t = t let top_of = top_of end) - - let name () = "lifted integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let lift1 f x = match x with - | `Lifted x -> `Lifted (f x) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> `Lifted (f x y) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Flattened = Flat (Integers (IntOps.Int64Ops)) -module Lifted = Lift (Integers (IntOps.Int64Ops)) - -module Reverse (Base: IkindUnawareS) = -struct - include Base - include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) -end - -module BISet = struct - include SetDomain.Make (IntOps.BigIntOps) - let is_singleton s = cardinal s = 1 -end - -(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) -module Exclusion = -struct - module R = Interval32 - (* We use these types for the functions in this module to make the intended meaning more explicit *) - type t = Exc of BISet.t * Interval32.t - type inc = Inc of BISet.t [@@unboxed] - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) - - let cardinality_BISet s = - Z.of_int (BISet.cardinal s) - - let leq_excl_incl (Exc (xs, r)) (Inc ys) = - (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) - let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in - let card_b = cardinality_BISet ys in - if Z.compare lower_bound_cardinality_a card_b > 0 then - false - else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) - let min_a = min_of_range r in - let max_a = max_of_range r in - GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) - - let leq (Exc (xs, r)) (Exc (ys, s)) = - let min_a, max_a = min_of_range r, max_of_range r in - let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) - if not excluded_check - then false - else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) - if R.leq r s then true - else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) - then - let min_b, max_b = min_of_range s, max_of_range s in - let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) - if Z.compare min_a min_b < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) - else - true - in - let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) - if Z.compare max_b max_a < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) - else - true - in - leq1 && (leq2 ()) - else - false - end - end -end - -module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) -struct - module S = BISet - module R = Interval32 (* range for exclusion *) - - (* Ikind used for intervals representing the domain *) - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - - type t = [ - | `Excluded of S.t * R.t - | `Definite of Z.t - | `Bot - ] [@@deriving eq, ord, hash] - type int_t = Z.t - let name () = "def_exc" - - - let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) - let top () = `Excluded (S.empty (), top_range) - let bot () = `Bot - let top_of ik = `Excluded (S.empty (), size ik) - let bot_of ik = bot () - - let show x = - let short_size x = "("^R.show x^")" in - match x with - | `Bot -> "Error int" - | `Definite x -> Z.to_string x - (* Print the empty exclusion as if it was a distinct top element: *) - | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l - (* Prepend the exclusion sets with something: *) - | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let maximal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.max_of_range r) - | `Bot -> None - - let minimal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.min_of_range r) - | `Bot -> None - - let in_range r i = - if Z.compare i Z.zero < 0 then - let lowerb = Exclusion.min_of_range r in - Z.compare lowerb i <= 0 - else - let upperb = Exclusion.max_of_range r in - Z.compare i upperb <= 0 - - let is_top x = x = top () - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Definite x -> if i = x then `Eq else `Neq - | `Excluded (s,r) -> if S.mem i s then `Neq else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function - | `Excluded (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - `Excluded (s, r) - else if ik = IBool then (* downcast to bool *) - if S.mem Z.zero s then - `Definite Z.one - else - `Excluded (S.empty(), r') - else - (* downcast: may overflow *) - (* let s' = S.map (Size.cast ik) s in *) - (* We want to filter out all i in s' where (t)x with x in r could be i. *) - (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) - (* S.diff s' s, r' *) - (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) - `Excluded (S.empty (), r') - | `Definite x -> `Definite (Size.cast ik x) - | `Bot -> `Bot - - (* Wraps definite values and excluded values according to the ikind. - * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. - * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. - *) - let norm ik v = - match v with - | `Excluded (s, r) -> - let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in - (* If no overflow occurred, just return x *) - if not possibly_overflowed then ( - v - ) - (* Else, if an overflow might have occurred but we should just ignore it *) - else if should_ignore_overflow ik then ( - let r = size ik in - (* filter out excluded elements that are not in the range *) - let mapped_excl = S.filter (in_range r) s in - `Excluded (mapped_excl, r) - ) - (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) - else if not (should_wrap ik) then ( - top_of ik - ) else ( - (* Else an overflow occurred that we should treat with wrap-around *) - let r = size ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in - match ik with - | IBool -> - begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with - | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) - | true, false -> `Definite Z.one (* Not {0} -> 1 *) - | false, true -> `Definite Z.zero (* Not {1} -> 0 *) - | true, true -> `Bot (* Not {0, 1} -> bot *) - end - | ik -> - `Excluded (mapped_excl, r) - ) - | `Definite x -> - let min, max = Size.range ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - if should_wrap ik then ( - cast_to ik v - ) - else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( - v - ) - else if should_ignore_overflow ik then ( - M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; - `Bot - ) - else ( - top_of ik - ) - | `Bot -> `Bot - - let leq x y = match (x,y) with - (* `Bot <= x is always true *) - | `Bot, _ -> true - (* Anything except bot <= bot is always false *) - | _, `Bot -> false - (* Two known values are leq whenever equal *) - | `Definite (x: int_t), `Definite y -> x = y - (* A definite value is leq all exclusion sets that don't contain it *) - | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) - (* No finite exclusion set can be leq than a definite value *) - | `Excluded (xs, xr), `Definite d -> - Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) - | `Excluded (xs,xr), `Excluded (ys,yr) -> - Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) - - let join' ?range ik x y = - match (x,y) with - (* The least upper bound with the bottom element: *) - | `Bot, x -> x - | x, `Bot -> x - (* The case for two known values: *) - | `Definite (x: int_t), `Definite y -> - (* If they're equal, it's just THAT value *) - if x = y then `Definite x - (* Unless one of them is zero, we can exclude it: *) - else - let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in - `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) - (* A known value and an exclusion set... the definite value should no - * longer be excluded: *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> - if not (in_range r x) then - let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in - `Excluded (S.remove x s, R.join a r) - else - `Excluded (S.remove x s, r) - (* For two exclusion sets, only their intersection can be excluded: *) - | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) - - let join ik = join' ik - - - let widen ik x y = - if get_def_exc_widen_by_join () then - join' ik x y - else if equal x y then - x - else - join' ~range:(size ik) ik x y - - - let meet ik x y = - match (x,y) with - (* Greatest LOWER bound with the least element is trivial: *) - | `Bot, _ -> `Bot - | _, `Bot -> `Bot - (* Definite elements are either equal or the glb is bottom *) - | `Definite x, `Definite y -> if x = y then `Definite x else `Bot - (* The glb of a definite element and an exclusion set is either bottom or - * just the element itself, if it isn't in the exclusion set *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x - (* The greatest lower bound of two exclusion sets is their union, this is - * just DeMorgans Law *) - | `Excluded (x,r1), `Excluded (y,r2) -> - let r' = R.meet r1 r2 in - let s' = S.union x y |> S.filter (in_range r') in - `Excluded (s', r') - - let narrow ik x y = x - - let of_int ik x = norm ik @@ `Definite x - let to_int x = match x with - | `Definite x -> Some x - | _ -> None - - let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) - - let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) - let of_bool = of_bool_cmp - let to_bool x = - match x with - | `Definite x -> Some (IntOps.BigIntOps.to_bool x) - | `Excluded (s,r) when S.mem Z.zero s -> Some true - | _ -> None - let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in - norm ik @@ (`Excluded (ex, r)) - - let to_bitfield ik x = - let one_mask = Z.lognot Z.zero - in (one_mask, one_mask) - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let of_excl_list t l = - let r = size t in (* elements in l are excluded from the full range of t! *) - `Excluded (List.fold_right S.add l (S.empty ()), r) - let is_excl_list l = match l with `Excluded _ -> true | _ -> false - let to_excl_list (x:t) = match x with - | `Definite _ -> None - | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) - | `Bot -> None - - let to_incl_list x = match x with - | `Definite x -> Some [x] - | `Excluded _ -> None - | `Bot -> None - - let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) - (* If the Int64 might overflow on us during computation, we instead go to top_range *) - match R.minimal r, R.maximal r with - | _ -> - let rf m = (size % Size.min_for % f) (m r) in - let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in - R.join r1 r2 - - (* Default behaviour for unary operators, simply maps the function to the - * DefExc data structure. *) - let lift1 f ik x = norm ik @@ match x with - | `Excluded (s,r) -> - let s' = S.map f s in - `Excluded (s', apply_range f r) - | `Definite x -> `Definite (f x) - | `Bot -> `Bot - - let lift2 f ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite _ - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (f x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - (* Default behaviour for binary operators that are injective in either - * argument, so that Exclusion Sets can be used: *) - let lift2_inj f ik x y = - let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in - norm ik @@ - match x,y with - (* If both are exclusion sets, there isn't anything we can do: *) - | `Excluded _, `Excluded _ -> top () - (* A definite value should be applied to all members of the exclusion set *) - | `Definite x, `Excluded (s,r) -> def_exc f x s r - (* Same thing here, but we should flip the operator to map it properly *) - | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r - (* The good case: *) - | `Definite x, `Definite y -> `Definite (f x y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The equality check: *) - let eq ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x equal to an exclusion set, if it is a member then NO otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x = y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The inequality check: *) - let ne ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x <> y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x - let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y - - let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y - let mul ?no_ov ik x y = norm ik @@ match x, y with - | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x - | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y - | `Definite a, `Excluded (s,r) - (* Integer multiplication with even numbers is not injective. *) - (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) - | _ -> lift2_inj Z.mul ik x y - let div ?no_ov ik x y = lift2 Z.div ik x y - let rem ik x y = lift2 Z.rem ik x y - - (* Comparison handling copied from Enums. *) - let handle_bot x y f = match x, y with - | `Bot, `Bot -> `Bot - | `Bot, _ - | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> f () - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let lognot = lift1 Z.lognot - - let logand ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite i -> - (* Except in two special cases *) - if Z.equal i Z.zero then - `Definite Z.zero - else if Z.equal i Z.one then - of_interval IBool (Z.zero, Z.one) - else - top () - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - norm ik @@ lift2 shift_op_big_int ik x y - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - (* TODO: lift does not treat Not {0} as true. *) - let c_logand ik x y = - match to_bool x, to_bool y with - | Some false, _ - | _, Some false -> - of_bool ik false - | _, _ -> - lift2 IntOps.BigIntOps.c_logand ik x y - let c_logor ik x y = - match to_bool x, to_bool y with - | Some true, _ - | _, Some true -> - of_bool ik true - | _, _ -> - lift2 IntOps.BigIntOps.c_logor ik x y - let c_lognot ik = eq ik (of_int ik Z.zero) - - let invariant_ikind e ik (x:t) = - match x with - | `Definite x -> - IntInvariant.of_int e ik x - | `Excluded (s, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let si = IntInvariant.of_excl_list e ik (S.elements s) in - Invariant.(ri && si) - | `Bot -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - let excluded s = from_excl ik s in - let definite x = of_int ik x in - let shrink = function - | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) - | `Bot -> empty - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map excluded (S.arbitrary ()); - 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); - 1, QCheck.always `Bot - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = a - let refine_with_interval ik a b = match a, b with - | x, Some(i) -> meet ik x (of_interval ik i) - | _ -> a - let refine_with_bitfield ik x y = x - let refine_with_excl_list ik a b = match a, b with - | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) -module Enums : S with type int_t = Z.t = struct - module R = Interval32 (* range for exclusion *) - - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) - - type int_t = Z.t - let name () = "enums" - let bot () = failwith "bot () not implemented for Enums" - let top () = failwith "top () not implemented for Enums" - let bot_of ik = Inc (BISet.empty ()) - let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) - let top_of ik = - match ik with - | IBool -> top_bool - | _ -> Exc (BISet.empty (), size ik) - - let range ik = Size.range ik - - (* - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) - let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 - - let show = function - | Inc xs when BISet.is_empty xs -> "bot" - | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" - | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - (* Normalization function for enums, that handles overflows for Inc. - As we do not compute on Excl, we do not have to perform any overflow handling for it. *) - let norm ikind v = - let min, max = range ikind in - (* Whether the value v lies within the values of the specified ikind. *) - let value_in_ikind v = - Z.compare min v <= 0 && Z.compare v max <= 0 - in - match v with - | Inc xs when BISet.for_all value_in_ikind xs -> v - | Inc xs -> - if should_wrap ikind then - Inc (BISet.map (Size.cast ikind) xs) - else if should_ignore_overflow ikind then - Inc (BISet.filter value_in_ikind xs) - else - top_of ikind - | Exc (xs, r) -> - (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: - let range_in_ikind r = - R.leq r (size ikind) - in - let r_min, r_max = min_of_range r, max_of_range r in - assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) - begin match ikind with - | IBool -> - begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with - | false, false -> top_bool (* Not {} -> {0, 1} *) - | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) - | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) - | true, true -> bot_of ikind (* Not {0, 1} -> bot *) - end - | _ -> - v - end - - - let equal_to i = function - | Inc x -> - if BISet.mem i x then - if BISet.is_singleton x then `Eq - else `Top - else `Neq - | Exc (x, r) -> - if BISet.mem i x then `Neq - else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with - | Exc (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - Exc (s, r) - else if ik = IBool then (* downcast to bool *) - if BISet.mem Z.zero s then - Inc (BISet.singleton Z.one) - else - Exc (BISet.empty(), r') - else (* downcast: may overflow *) - Exc ((BISet.empty ()), r') - | Inc xs -> - let casted_xs = BISet.map (Size.cast ik) xs in - if Cil.isSigned ik && not (BISet.equal xs casted_xs) - then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) - else Inc casted_xs - - let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) - - let of_interval ?(suppress_ovwarn=false) ik (x, y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in - norm ik @@ (Exc (ex, r)) - - let join _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.union x y) - | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) - | Exc (x,r), Inc y - | Inc y, Exc (x,r) -> - let r = if BISet.is_empty y - then r - else - let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in - let range = R.join min_el_range max_el_range in - R.join r range - in - Exc (BISet.diff x y, r) - - let meet _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.inter x y) - | Exc (x,r1), Exc (y,r2) -> - let r = R.meet r1 r2 in - let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in - let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in - (* We remove those elements from the exclusion set that do not fit in the range anyway *) - let excl = BISet.union (filter_by_range x) (filter_by_range y) in - Exc (excl, r) - | Inc x, Exc (y,r) - | Exc (y,r), Inc x -> Inc (BISet.diff x y) - - let widen = join - let narrow = meet - let leq a b = - match a, b with - | Inc xs, Exc (ys, r) -> - if BISet.is_empty xs - then true - else - let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in - let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in - (* Check that the xs fit into the range r *) - Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && - (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) - BISet.for_all (fun x -> not (BISet.mem x ys)) xs - | Inc xs, Inc ys -> - BISet.subset xs ys - | Exc (xs, r), Exc (ys, s) -> - Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) - | Exc (xs, r), Inc ys -> - Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) - - let handle_bot x y f = match is_bot x, is_bot y with - | false, false -> f () - | true, false - | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | true, true -> Inc (BISet.empty ()) - - let lift1 f ikind v = norm ikind @@ match v with - | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) - | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) - | _ -> top_of ikind - - let lift2 f (ikind: Cil.ikind) u v = - handle_bot u v (fun () -> - norm ikind @@ match u, v with - | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) - | _,_ -> top_of ikind) - - let lift2 f ikind a b = - try lift2 f ikind a b with Division_by_zero -> top_of ikind - - let neg ?no_ov = lift1 Z.neg - let add ?no_ov ikind a b = - match a, b with - | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,y -> lift2 Z.add ikind x y - let sub ?no_ov = lift2 Z.sub - let mul ?no_ov ikind a b = - match a, b with - | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b - | x,y -> lift2 Z.mul ikind x y - - let div ?no_ov ikind a b = match a, b with - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | x,y -> lift2 Z.div ikind x y - - let rem = lift2 Z.rem - - let lognot = lift1 Z.lognot - let logand = lift2 Z.logand - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - handle_bot x y (fun () -> - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - lift2 shift_op_big_int ik x y) - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - - let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) - let to_bool = function - | Inc e when BISet.is_empty e -> None - | Exc (e,_) when BISet.is_empty e -> None - | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false - | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true - | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true - | _ -> None - let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None - - let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None - let of_excl_list ik xs = - let min_ik, max_ik = Size.range ik in - let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in - norm ik @@ Exc (exc, size ik) - let is_excl_list = BatOption.is_some % to_excl_list - let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None - - let to_bitfield ik x = - let one_mask = Z.lognot Z.zero - in (one_mask, one_mask) - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let c_lognot ik x = - if is_bot x - then x - else - match to_bool x with - | Some b -> of_bool ik (not b) - | None -> top_bool - - let c_logand = lift2 IntOps.BigIntOps.c_logand - let c_logor = lift2 IntOps.BigIntOps.c_logor - let maximal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) - | Exc (excl,r) -> - let rec decrement_while_contained v = - if BISet.mem v excl - then decrement_while_contained (Z.pred v) - else v - in - let range_max = Exclusion.max_of_range r in - Some (decrement_while_contained range_max) - | _ (* bottom case *) -> None - - let minimal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) - | Exc (excl,r) -> - let rec increment_while_contained v = - if BISet.mem v excl - then increment_while_contained (Z.succ v) - else v - in - let range_min = Exclusion.min_of_range r in - Some (increment_while_contained range_min) - | _ (* bottom case *) -> None - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let eq ik x y = - handle_bot x y (fun () -> - match x, y with - | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) - | _, _ -> - if is_bot (meet ik x y) then - (* If the meet is empty, there is no chance that concrete values are equal *) - of_bool ik false - else - top_bool) - - let ne ik x y = c_lognot ik (eq ik x y) - - let invariant_ikind e ik x = - match x with - | Inc ps -> - IntInvariant.of_incl_list e ik (BISet.elements ps) - | Exc (ns, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in - Invariant.(ri && nsi) - - - let arbitrary ik = - let open QCheck.Iter in - let neg s = of_excl_list ik (BISet.elements s) in - let pos s = norm ik (Inc s) in - let shrink = function - | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) - | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map neg (BISet.arbitrary ()); - 10, QCheck.map pos (BISet.arbitrary ()); - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = - let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in - match a, b with - | Inc e, None -> bot_of ik - | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) - | _ -> a - - let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) - - let refine_with_bitfield ik x y = x - - let refine_with_excl_list ik a b = - match b with - | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - - let refine_with_incl_list ik a b = - match a, b with - | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) - | _ -> a - - let project ik p t = t -end - -module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = -struct - let name () = "congruences" - type int_t = Z.t - - (* represents congruence class of c mod m, None is bot *) - type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] - - let ( *: ) = Z.mul - let (+:) = Z.add - let (-:) = Z.sub - let (%:) = Z.rem - let (/:) = Z.div - let (=:) = Z.equal - let (<:) x y = Z.compare x y < 0 - let (>:) x y = Z.compare x y > 0 - let (<=:) x y = Z.compare x y <= 0 - let (>=:) x y = Z.compare x y >= 0 - (* a divides b *) - let ( |: ) a b = - if a =: Z.zero then false else (b %: a) =: Z.zero - - let normalize ik x = - match x with - | None -> None - | Some (c, m) -> - if m =: Z.zero then - if should_wrap ik then - Some (Size.cast ik c, m) - else - Some (c, m) - else - let m' = Z.abs m in - let c' = c %: m' in - if c' <: Z.zero then - Some (c' +: m', m') - else - Some (c' %: m', m') - - let range ik = Size.range ik - - let top () = Some (Z.zero, Z.one) - let top_of ik = Some (Z.zero, Z.one) - let bot () = None - let bot_of ik = bot () - - let show = function ik -> match ik with - | None -> "⟂" - | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c - | Some (c, m) -> - let a = if c =: Z.zero then "" else Z.to_string c in - let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in - let c = if a = "" || b = "" then "" else "+" in - a^c^b - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let is_top x = x = top () - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq - | Some (a, b) -> if i %: b =: a then `Top else `Neq - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero - | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 - (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 - Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) - - let leq x y = - let res = leq x y in - if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; - res - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (c1,m1), Some (c2,m2) -> - let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in - normalize ik (Some (c1, m3)) - - let join ik (x:t) y = - let res = join ik x y in - if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; - res - - - let meet ik x y = - (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) - let congruence_series a c m = - let rec next a1 c1 a2 c2 = - if a2 |: a1 then (a2, c2) - else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) - in next m Z.zero a c - in - let simple_case i c m = - if m |: (i -: c) - then Some (i, Z.zero) else None - in - match x, y with - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 - | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 - | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> - let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in - normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) - | _ -> None - - let meet ik x y = - let res = meet ik x y in - if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; - res - - let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None - let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) - let zero = Some (Z.zero, Z.zero) - let one = Some (Z.one, Z.zero) - let top_bool = top() - - let of_bool _ik = function true -> one | false -> zero - - let to_bool (a: t) = match a with - | None -> None - | x when equal zero x -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = top() - - let ending = starting - - let of_congruence ik (c,m) = normalize ik @@ Some(c,m) - - let to_bitfield ik x = - let is_power_of_two x = (Z.logand x (x -: Z.one) = Z.zero) in - match x with None -> (Z.zero, Z.zero) | Some (c,m) -> - if m = Z.zero then (Z.lognot c, c) - else if is_power_of_two m then - let mod_mask = m -: Z.one in - let z = Z.lognot c in - let o = Z.logor (Z.lognot mod_mask) c in - (z,o) - else (Z.lognot Z.zero, Z.lognot Z.zero) - - let maximal t = match t with - | Some (x, y) when y =: Z.zero -> Some x - | _ -> None - - let minimal t = match t with - | Some (x,y) when y =: Z.zero -> Some x - | _ -> None - - (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) - let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = - match x with - | None -> None - | Some (c, m) when m =: Z.zero -> - let c' = Size.cast t c in - (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) - (* We go with GCC behavior here: *) - (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) - (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) - (* Clang behaves the same but they never document that anywhere *) - Some (c', m) - | _ -> - let (min_t, max_t) = range t in - let p ikorg = - let (min_ikorg, max_ikorg) = range ikorg in - ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) - in - match torg with - | Some (Cil.TInt (ikorg, _)) when p ikorg -> - if M.tracing then M.trace "cong-cast" "some case"; - x - | _ -> top () - - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = - let pretty_bool _ x = Pretty.text (string_of_bool x) in - let res = cast_to ?torg ?no_ov t x in - if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; - res - - let widen = join - - let widen ik x y = - let res = widen ik x y in - if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; - res - - let narrow = meet - - let log f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) - let c_logand = log (&&) - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let shift_right _ _ _ = top() - - let shift_right ik x y = - let res = shift_right ik x y in - if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; - res - - let shift_left ik x y = - (* Naive primality test *) - (* let is_prime n = - let n = Z.abs n in - let rec is_prime' d = - (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) - in - not (n =: Z.one) && is_prime' (Z.of_int 2) - in *) - match x, y with - | None, None -> None - | None, _ - | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik - | Some (c, m), Some (c', m') -> - let (_, max_ik) = range ik in - if m =: Z.zero && m' =: Z.zero then - normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) - else - let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) - (* TODO: commented out because fails test with _Bool *) - (* if is_prime (m' +: Z.one) then - normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) - else *) - normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) - - let shift_left ik x y = - let res = shift_left ik x y in - if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; - res - - (* Handle unsigned overflows. - From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. - The congruence modulo b may not persist on an overflow. *) - let handle_overflow ik (c, m) = - if m =: Z.zero then - normalize ik (Some (c, m)) - else - (* Find largest m'=2^k (for some k) such that m is divisible by m' *) - let tz = Z.trailing_zeros m in - let m' = Z.shift_left Z.one tz in - - let max = (snd (Size.range ik)) +: Z.one in - if m' >=: max then - (* if m' >= 2 ^ {bitlength}, there is only one value in range *) - let c' = c %: max in - Some (c', Z.zero) - else - normalize ik (Some (c, m')) - - let mul ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) - in - match x, y with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) when no_ov -> - Some (no_ov_case (c1, m1) (c2, m2)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b ) - | _ -> top () - - let mul ?no_ov ik x y = - let res = mul ?no_ov ik x y in - if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; - res - - let neg ?(no_ov=false) ik x = - match x with - | None -> bot() - | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x - - let add ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 +: c2, Z.gcd m1 m2 - in - match (x, y) with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some a, Some b when no_ov -> - normalize ik (Some (no_ov_case a b)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b) - | _ -> top () - - - let add ?no_ov ik x y = - let res = add ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "add : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) - - - let sub ?no_ov ik x y = - let res = sub ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let lognot ik x = match x with - | None -> None - | Some (c, m) -> - if (Cil.isSigned ik) then - sub ik (neg ik x) one - else - let (_, max_ik) = range ik in - Some (Z.sub max_ik c, m) - - (** The implementation of the bit operations could be improved based on the master’s thesis - 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. - see: http://www.es.mdh.se/pdf_publications/948.pdf *) - let bit2 f ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) - else top () - - let logor ik x y = bit2 Z.logor ik x y - - let logand ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then - (* both arguments constant *) - Some (Z.logand c c', Z.zero) - else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then - (* x & 1 and x == c (mod 2*z) *) - (* Value is equal to LSB of c *) - Some (Z.logand c c', Z.zero) - else - top () - - let logxor ik x y = bit2 Z.logxor ik x y - - let rem ik x y = - match x, y with - | None, None -> bot() - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some(c2, m2) -> - if m2 =: Z.zero then - if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then - Some (c1 %: c2, Z.zero) - else - normalize ik (Some (c1, (Z.gcd m1 c2))) - else - normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) - - let rem ik x y = let res = rem ik x y in - if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; - res - - let div ?(no_ov=false) ik x y = - match x,y with - | None, None -> bot () - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, x when leq zero x -> top () - | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () - | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) - | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) - | _, _ -> top () - - - let div ?no_ov ik x y = - let res = div ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty - res ; - res - - let ne ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) - | x, y -> if meet ik x y = None then of_bool ik true else top_bool - - let eq ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) - | x, y -> if meet ik x y <> None then top_bool else of_bool ik false - - let comparison ik op x y = match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) -> - if m1 =: Z.zero && m2 =: Z.zero then - if op c1 c2 then of_bool ik true else of_bool ik false - else - top_bool - - let ge ik x y = comparison ik (>=:) x y - - let ge ik x y = - let res = ge ik x y in - if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let le ik x y = comparison ik (<=:) x y - - let le ik x y = - let res = le ik x y in - if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let gt ik x y = comparison ik (>:) x y - - - let gt ik x y = - let res = gt ik x y in - if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; - res - - let lt ik x y = comparison ik (<:) x y - - let lt ik x y = - let res = lt ik x y in - if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; - res - - let invariant_ikind e ik x = - match x with - | x when is_top x -> Invariant.top () - | Some (c, m) when m =: Z.zero -> - IntInvariant.of_int e ik c - | Some (c, m) -> - let open Cil in - let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in - Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) - | None -> Invariant.none - - let arbitrary ik = - let open QCheck in - let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in - let cong_arb = pair int_arb int_arb in - let of_pair ik p = normalize ik (Some p) in - let to_pair = Option.get in - set_print show (map ~rev:to_pair (of_pair ik) cong_arb) - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =: Z.zero then - if c <: x || c >: y then None else Some (c, Z.zero) - else - let rcx = x +: ((c -: x) %: Z.abs m) in - let lcy = y -: ((y -: c) %: Z.abs m) in - if rcx >: lcy then None - else if rcx =: lcy then Some (rcx, Z.zero) - else cong - | _ -> None - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = - let pretty_intv _ i = - match i with - | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u - | _ -> Pretty.text ("Display Error") in - let refn = refine_with_interval ik cong intv in - if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; - refn - - let refine_with_bitfield ik a b = a - - let refine_with_congruence ik a b = meet ik a b - let refine_with_excl_list ik a b = a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct - - include D - - let lift v = (v, {overflow=false; underflow=false}) - - let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = lift @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = lift @@ D.shift_left ik x y - - let shift_right ik x y = lift @@ D.shift_right ik x y - -end - - - - - - -(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) -(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) -module IntDomTupleImpl = struct - include Printable.Std (* for default invariant, tag, ... *) - - open Batteries - type int_t = Z.t - module I1 = SOverflowLifter (DefExc) - module I2 = Interval - module I3 = SOverflowLifter (Enums) - module I4 = SOverflowLifter (Congruence) - module I5 = IntervalSetFunctor (IntOps.BigIntOps) - module I6 = BitfieldFunctor (IntOps.BigIntOps) - - type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option * I6.t option - [@@deriving eq, ord, hash] - - let name () = "intdomtuple" - - (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) - let no_interval = GobTuple.Tuple6.map2 (const None) - let no_intervalSet = GobTuple.Tuple6.map5 (const None) - - type 'a m = (module SOverflow with type t = 'a) - type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) - - (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) - type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) - type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) - type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) - - type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) - type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) - type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] - type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] - type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] - type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) - let create r x ((p1, p2, p3, p4, p5, p6): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5), f p6 @@ r.fi (module I6) - let create r x = (* use where values are introduced *) - create r x (int_precision_from_node_or_config ()) - let create2 r x ((p1, p2, p3, p4, p5, p6): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) , f p6 @@ r.fi2 (module I6) - let create2 r x = (* use where values are introduced *) - create2 r x (int_precision_from_node_or_config ()) - - let no_overflow ik = function - | Some(_, {underflow; overflow}) -> not (underflow || overflow) - | _ -> false - - let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = - let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in - if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( - let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in - let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in - let underflow = underflow_intv && underflow_intv_set in - let overflow = overflow_intv && overflow_intv_set in - set_overflow_flag ~cast ~underflow ~overflow ik; - ); - no_ov - - let create2_ovc ik r x ((p1, p2, p3, p4, p5,p6): int_precision) = - let f b g = if b then Some (g x) else None in - let map x = Option.map fst x in - let intv = f p2 @@ r.fi2_ovc (module I2) in - let intv_set = f p5 @@ r.fi2_ovc (module I5) in - ignore (check_ov ~cast:false ik intv intv_set); - map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) - - let create2_ovc ik r x = (* use where values are introduced *) - create2_ovc ik r x (int_precision_from_node_or_config ()) - - - let opt_map2 f ?no_ov = - curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None - - let to_list x = GobTuple.Tuple6.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) - let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) - - let exists = function - | (Some true, _, _, _, _,_) - | (_, Some true, _, _, _,_) - | (_, _, Some true, _, _,_) - | (_, _, _, Some true, _,_) - | (_, _, _, _, Some true,_) - | (_, _, _, _, _, Some true) - -> true - | _ -> - false - - let for_all = function - | (Some false, _, _, _, _,_) - | (_, Some false, _, _, _,_) - | (_, _, Some false, _, _,_) - | (_, _, _, Some false, _,_) - | (_, _, _, _, Some false,_) - | (_, _, _, _, _, Some false) - -> - false - | _ -> - true - - (* f0: constructors *) - let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () - let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () - let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } - let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } - let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } - let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} - let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } - let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } - let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } - let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } - let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } - let of_bitfield ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_bitfield ik } - - let refine_with_congruence ik ((a, b, c, d, e, f) : t) (cong : (int_t * int_t) option) : t= - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_congruence ik a cong - , opt I2.refine_with_congruence ik b cong - , opt I3.refine_with_congruence ik c cong - , opt I4.refine_with_congruence ik d cong - , opt I5.refine_with_congruence ik e cong - , opt I6.refine_with_congruence ik f cong - ) - - let refine_with_interval ik (a, b, c, d, e,f) intv = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_interval ik a intv - , opt I2.refine_with_interval ik b intv - , opt I3.refine_with_interval ik c intv - , opt I4.refine_with_interval ik d intv - , opt I5.refine_with_interval ik e intv - , opt I6.refine_with_interval ik f intv ) - - let refine_with_bitfield ik (a, b, c, d, e,f) bf = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_bitfield ik a bf - , opt I2.refine_with_bitfield ik b bf - , opt I3.refine_with_bitfield ik c bf - , opt I4.refine_with_bitfield ik d bf - , opt I5.refine_with_bitfield ik e bf - , opt I6.refine_with_bitfield ik f bf ) - - let refine_with_excl_list ik (a, b, c, d, e,f) excl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_excl_list ik a excl - , opt I2.refine_with_excl_list ik b excl - , opt I3.refine_with_excl_list ik c excl - , opt I4.refine_with_excl_list ik d excl - , opt I5.refine_with_excl_list ik e excl - , opt I6.refine_with_excl_list ik f excl ) - - let refine_with_incl_list ik (a, b, c, d, e,f) incl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_incl_list ik a incl - , opt I2.refine_with_incl_list ik b incl - , opt I3.refine_with_incl_list ik c incl - , opt I4.refine_with_incl_list ik d incl - , opt I5.refine_with_incl_list ik e incl - , opt I6.refine_with_incl_list ik f incl ) - - - let mapp r (a, b, c, d, e, f) = - let map = BatOption.map in - ( map (r.fp (module I1)) a - , map (r.fp (module I2)) b - , map (r.fp (module I3)) c - , map (r.fp (module I4)) d - , map (r.fp (module I5)) e - , map (r.fp (module I6)) f) - - - let mapp2 r (a, b, c, d, e, f) = - BatOption. - ( map (r.fp2 (module I1)) a - , map (r.fp2 (module I2)) b - , map (r.fp2 (module I3)) c - , map (r.fp2 (module I4)) d - , map (r.fp2 (module I5)) e - , map (r.fp2 (module I6)) f) - - - (* exists/for_all *) - let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } - let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } - let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } - let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } - - let map2p r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - ( opt_map2 (r.f2p (module I1)) xa ya - , opt_map2 (r.f2p (module I2)) xb yb - , opt_map2 (r.f2p (module I3)) xc yc - , opt_map2 (r.f2p (module I4)) xd yd - , opt_map2 (r.f2p (module I5)) xe ye - , opt_map2 (r.f2p (module I6)) xf yf) - - (* f2p: binary projections *) - let (%%) f g x = f % (g x) (* composition for binary function g *) - - let leq = - for_all - %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} - - let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) - - let to_excl_list x = - let merge ps = - let (vs, rs) = List.split ps in - let (mins, maxs) = List.split rs in - (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge - - let to_incl_list x = - let hd l = match l with h::t -> h | _ -> [] in - let tl l = match l with h::t -> t | _ -> [] in - let a y = BatSet.of_list (hd y) in - let b y = BatList.map BatSet.of_list (tl y) in - let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge - - let to_bitfield ik x = - let bf_meet (z1,o1) (z2,o2) = (Z.logand z1 z2, Z.logand o1 o2) in - let bf_top = (Z.lognot Z.zero, Z.lognot Z.zero) in - let res_tup = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_bitfield ik } x - in List.fold bf_meet bf_top (to_list res_tup) - - let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in - if n = 1 then Some (List.hd xs) - else ( - if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) - None - ) - let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } - - let pretty () x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) - | _ -> - mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x - |> to_list - |> (fun xs -> - text "(" ++ ( - try - List.reduce (fun a b -> a ++ text "," ++ b) xs - with Invalid_argument _ -> - nil) - ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) - - let refine_functions ik : (t -> t) list = - let maybe reffun ik domtup dom = - match dom with Some y -> reffun ik domtup y | _ -> domtup - in - [(fun (a, b, c, d, e, f) -> refine_with_excl_list ik (a, b, c, d, e,f) (to_excl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> refine_with_incl_list ik (a, b, c, d, e,f) (to_incl_list (a, b, c, d, e,f))); - (fun (a, b, c, d, e, f) -> maybe refine_with_interval ik (a, b, c, d, e, f) b); (* TODO: get interval across all domains with minimal and maximal *) - (fun (a, b, c, d, e, f) -> maybe refine_with_congruence ik (a, b, c, d, e, f) d); - (fun (a, b, c, d, e, f) -> maybe refine_with_bitfield ik (a, b, c, d, e, f) f)] - - let refine ik ((a, b, c, d, e,f) : t ) : t = - let dt = ref (a, b, c, d, e,f) in - (match get_refinement () with - | "never" -> () - | "once" -> - List.iter (fun f -> dt := f !dt) (refine_functions ik); - | "fixpoint" -> - let quit_loop = ref false in - while not !quit_loop do - let old_dt = !dt in - List.iter (fun f -> dt := f !dt) (refine_functions ik); - quit_loop := equal old_dt !dt; - if is_bot !dt then dt := bot_of ik; quit_loop := true; - if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; - done; - | _ -> () - ); !dt - - - (* map with overflow check *) - let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e, f) = - let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in - let intv = map (r.f1_ovc (module I2)) b in - let intv_set = map (r.f1_ovc (module I5)) e in - let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a - , BatOption.map fst intv - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d - , BatOption.map fst intv_set - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) - - (* map2 with overflow check *) - let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in - let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in - let no_ov = check_ov ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya - , BatOption.map fst intv - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd - , BatOption.map fst intv_set - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) - - let map ik r (a, b, c, d, e, f) = - refine ik - BatOption. - ( map (r.f1 (module I1)) a - , map (r.f1 (module I2)) b - , map (r.f1 (module I3)) c - , map (r.f1 (module I4)) d - , map (r.f1 (module I5)) e - , map (r.f1 (module I6)) f) - - let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = - let r = - ( opt_map2 (r.f2 (module I1)) xa ya - , opt_map2 (r.f2 (module I2)) xb yb - , opt_map2 (r.f2 (module I3)) xc yc - , opt_map2 (r.f2 (module I4)) xd yd - , opt_map2 (r.f2 (module I5)) xe ye - , opt_map2 (r.f2 (module I6)) xf yf) - in - if norefine then r else refine ik r - - - (* f1: unary ops *) - let neg ?no_ov ik = - mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} - - let lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} - - let c_lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = - mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} - - (* fp: projections *) - let equal_to i x = - let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> GobTuple.Tuple6.enum |> List.of_enum |> List.filter_map identity in - if List.mem `Eq xs then `Eq else - if List.mem `Neq xs then `Neq else - `Top - - let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } - let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } - let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } - (* others *) - let show x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v - | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x - |> to_list - |> String.concat "; " - let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } - - (* `map/opt_map` are used by `project` *) - let opt_map b f = - curry @@ function None, true -> f | x, y when y || b -> x | _ -> None - let map ~keep r (i1, i2, i3, i4, i5, i6) (b1, b2, b3, b4, b5, b6) = - ( opt_map keep (r.f3 (module I1)) i1 b1 - , opt_map keep (r.f3 (module I2)) i2 b2 - , opt_map keep (r.f3 (module I3)) i3 b3 - , opt_map keep (r.f3 (module I4)) i4 b4 - , opt_map keep (r.f3 (module I5)) i5 b5 - , opt_map keep (r.f3 (module I6)) i6 b6) - - (** Project tuple t to precision p - * We have to deactivate IntDomains after the refinement, since we might - * lose information if we do it before. E.g. only "Interval" is active - * and shall be projected to only "Def_Exc". By seting "Interval" to None - * before refinement we have no information for "Def_Exc". - * - * Thus we have 3 Steps: - * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element - * 2. Refine the padded t - * 3. Set elements of t to `None` if p is false for this element - * - * Side Note: - * ~keep is used to reuse `map/opt_map` for Step 1 and 3. - * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. - * This way we won't loose any information for the refinement. - * ~keep:false will set the elements to `None` as defined by p *) - let project ik (p: int_precision) t = - let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in - let t_refined = refine ik t_padded in - map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p - - - (* f2: binary ops *) - let join ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} - - let meet ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} - - let widen ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} - - let narrow ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} - - let add ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} - - let sub ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} - - let mul ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} - - let div ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} - - let rem ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} - - let lt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} - - let gt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} - - let le ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} - - let ge ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} - - let eq ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} - - let ne ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} - - let logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} - - let logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} - - let logxor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} - - let shift_left ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} - - let shift_right ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} - - let c_logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} - - let c_logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} - - - (* printing boilerplate *) - let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y - let printXml f x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) - | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) - - let invariant_ikind e ik ((_, _, _, x_cong, x_intset, _) as x) = - (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) - let simplify_int fallback = - match to_int x with - | Some v -> - (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) - IntInvariant.of_int e ik v - | None -> - fallback () - in - let simplify_all () = - match to_incl_list x with - | Some ps -> - (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) - IntInvariant.of_incl_list e ik ps - | None -> - (* Get interval bounds from all domains (intervals and exclusion set ranges). *) - let min = minimal x in - let max = maximal x in - let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) - (* "Refine" out-of-bounds exclusions for simpler output. *) - let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in - let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in - Invariant.( - IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) - IntInvariant.of_excl_list e ik ns && - Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) - Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) - ) - in - let simplify_none () = - let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in - List.fold_left (fun a i -> - Invariant.(a && i) - ) (Invariant.top ()) is - in - match GobConfig.get_string "ana.base.invariant.int.simplify" with - | "none" -> simplify_none () - | "int" -> simplify_int simplify_none - | "all" -> simplify_int simplify_all - | _ -> assert false - - let arbitrary ik = QCheck.(set_print show @@ tup6 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik)) (option (I6.arbitrary ik))) - - let relift (a, b, c, d, e, f) = - (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e, Option.map I6.relift f) -end - -module IntDomTuple = -struct - module I = IntDomLifter (IntDomTupleImpl) - include I - - let top () = failwith "top in IntDomTuple not supported. Use top_of instead." - let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} - - let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} -end - -let of_const (i, ik, str) = IntDomTuple.of_int ik i +include IntDomain0 + +include IntervalDomain +include IntervalSetDomain +include DefExcDomain +include EnumsDomain +include CongruenceDomain +include BitfieldDomain +include IntDomTuple diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 6c68724cc5..7be2183eb4 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -269,8 +269,8 @@ sig val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t val refine_with_bitfield: Cil.ikind -> t -> (int_t * int_t) -> t + val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t diff --git a/src/cdomain/value/cdomains/intDomain0.ml b/src/cdomain/value/cdomains/intDomain0.ml new file mode 100644 index 0000000000..7736057867 --- /dev/null +++ b/src/cdomain/value/cdomains/intDomain0.ml @@ -0,0 +1,933 @@ +open GobConfig +open GoblintCil +open Pretty +open PrecisionUtil + +module M = Messages + +let (%) = Batteries.(%) +let (|?) = Batteries.(|?) + +exception IncompatibleIKinds of string +exception Unknown +exception Error +exception ArithmeticOnIntegerBot of string + + + + +(** Define records that hold mutable variables representing different Configuration values. + * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) +type ana_int_config_values = { + mutable interval_threshold_widening : bool option; + mutable interval_narrow_by_meet : bool option; + mutable def_exc_widen_by_join : bool option; + mutable interval_threshold_widening_constants : string option; + mutable refinement : string option; +} + +let ana_int_config: ana_int_config_values = { + interval_threshold_widening = None; + interval_narrow_by_meet = None; + def_exc_widen_by_join = None; + interval_threshold_widening_constants = None; + refinement = None; +} + +let get_interval_threshold_widening () = + if ana_int_config.interval_threshold_widening = None then + ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); + Option.get ana_int_config.interval_threshold_widening + +let get_interval_narrow_by_meet () = + if ana_int_config.interval_narrow_by_meet = None then + ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); + Option.get ana_int_config.interval_narrow_by_meet + +let get_def_exc_widen_by_join () = + if ana_int_config.def_exc_widen_by_join = None then + ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); + Option.get ana_int_config.def_exc_widen_by_join + +let get_interval_threshold_widening_constants () = + if ana_int_config.interval_threshold_widening_constants = None then + ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); + Option.get ana_int_config.interval_threshold_widening_constants + +let get_refinement () = + if ana_int_config.refinement = None then + ana_int_config.refinement <- Some (get_string "ana.int.refinement"); + Option.get ana_int_config.refinement + + + +(** Whether for a given ikind, we should compute with wrap-around arithmetic. + * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) +let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" + +(** Whether for a given ikind, we should assume there are no overflows. + * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) +let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" + +let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds +let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) + +type overflow_info = { overflow: bool; underflow: bool;} + +let set_overflow_flag ~cast ~underflow ~overflow ik = + if !AnalysisState.executing_speculative_computations then + (* Do not produce warnings when the operations are not actually happening in code *) + () + else + let signed = Cil.isSigned ik in + if !AnalysisState.postsolving && signed && not cast then + AnalysisState.svcomp_may_overflow := true; + let sign = if signed then "Signed" else "Unsigned" in + match underflow, overflow with + | true, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign + | true, false -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign + | false, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign + | false, false -> assert false + +let reset_lazy () = + ResettableLazy.reset widening_thresholds; + ResettableLazy.reset widening_thresholds_desc; + ana_int_config.interval_threshold_widening <- None; + ana_int_config.interval_narrow_by_meet <- None; + ana_int_config.def_exc_widen_by_join <- None; + ana_int_config.interval_threshold_widening_constants <- None; + ana_int_config.refinement <- None + +module type Arith = +sig + type t + val neg: t -> t + val add: t -> t -> t + val sub: t -> t -> t + val mul: t -> t -> t + val div: t -> t -> t + val rem: t -> t -> t + + val lt: t -> t -> t + val gt: t -> t -> t + val le: t -> t -> t + val ge: t -> t -> t + val eq: t -> t -> t + val ne: t -> t -> t + + val lognot: t -> t + val logand: t -> t -> t + val logor : t -> t -> t + val logxor: t -> t -> t + + val shift_left : t -> t -> t + val shift_right: t -> t -> t + + val c_lognot: t -> t + val c_logand: t -> t -> t + val c_logor : t -> t -> t + +end + +module type ArithIkind = +sig + type t + val neg: Cil.ikind -> t -> t + val add: Cil.ikind -> t -> t -> t + val sub: Cil.ikind -> t -> t -> t + val mul: Cil.ikind -> t -> t -> t + val div: Cil.ikind -> t -> t -> t + val rem: Cil.ikind -> t -> t -> t + + val lt: Cil.ikind -> t -> t -> t + val gt: Cil.ikind -> t -> t -> t + val le: Cil.ikind -> t -> t -> t + val ge: Cil.ikind -> t -> t -> t + val eq: Cil.ikind -> t -> t -> t + val ne: Cil.ikind -> t -> t -> t + + val lognot: Cil.ikind -> t -> t + val logand: Cil.ikind -> t -> t -> t + val logor : Cil.ikind -> t -> t -> t + val logxor: Cil.ikind -> t -> t -> t + + val shift_left : Cil.ikind -> t -> t -> t + val shift_right: Cil.ikind -> t -> t -> t + + val c_lognot: Cil.ikind -> t -> t + val c_logand: Cil.ikind -> t -> t -> t + val c_logor : Cil.ikind -> t -> t -> t + +end + +(* Shared functions between S and Z *) +module type B = +sig + include Lattice.S + type int_t + val bot_of: Cil.ikind -> t + val top_of: Cil.ikind -> t + val to_int: t -> int_t option + val equal_to: int_t -> t -> [`Eq | `Neq | `Top] + + val to_bool: t -> bool option + val to_excl_list: t -> (int_t list * (int64 * int64)) option + val of_excl_list: Cil.ikind -> int_t list -> t + val is_excl_list: t -> bool + + val to_incl_list: t -> int_t list option + + val maximal : t -> int_t option + val minimal : t -> int_t option + + val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t +end + +(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) +module type IkindUnawareS = +sig + include B + include Arith with type t := t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: int_t -> t + val of_bool: bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t + val arbitrary: unit -> t QCheck.arbitrary + val invariant: Cil.exp -> t -> Invariant.t +end + +(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) +module type S = +sig + include B + include ArithIkind with type t:= t + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val neg : ?no_ov:bool -> Cil.ikind -> t -> t + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t + + val join: Cil.ikind -> t -> t -> t + val meet: Cil.ikind -> t -> t -> t + val narrow: Cil.ikind -> t -> t -> t + val widen: Cil.ikind -> t -> t -> t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t + val to_bitfield: Cil.ikind -> t -> int_t * int_t + val is_top_of: Cil.ikind -> t -> bool + val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t + + val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_bitfield: Cil.ikind -> t -> (int_t * int_t) -> t + val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t + val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t + + val project: Cil.ikind -> int_precision -> t -> t + val arbitrary: Cil.ikind -> t QCheck.arbitrary +end + +module type SOverflow = +sig + + include S + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val of_int : Cil.ikind -> int_t -> t * overflow_info + + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + + val shift_left : Cil.ikind -> t -> t -> t * overflow_info + + val shift_right : Cil.ikind -> t -> t -> t * overflow_info +end + +module type Y = +sig + (* include B *) + include B + include Arith with type t:= t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val of_bitfield: Cil.ikind -> int_t * int_t -> t + val to_bitfield: Cil.ikind -> t -> int_t * int_t + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val is_top_of: Cil.ikind -> t -> bool + + val project: int_precision -> t -> t + val invariant: Cil.exp -> t -> Invariant.t +end + +module type Z = Y with type int_t = Z.t + + +module IntDomLifter (I : S) = +struct + open Cil + type int_t = I.int_t + type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] + + let ikind {ikind; _} = ikind + + (* Helper functions *) + let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) + let lift op x = {x with v = op x.ikind x.v } + (* For logical operations the result is of type int *) + let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} + let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } + let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} + + let bot_of ikind = { v = I.bot_of ikind; ikind} + let bot () = failwith "bot () is not implemented for IntDomLifter." + let is_bot x = I.is_bot x.v + let top_of ikind = { v = I.top_of ikind; ikind} + let top () = failwith "top () is not implemented for IntDomLifter." + let is_top x = I.is_top x.v + + (* Leq does not check for ikind, because it is used in invariant with arguments of different type. + TODO: check ikinds here and fix invariant to work with right ikinds *) + let leq x y = I.leq x.v y.v + let join = lift2 I.join + let meet = lift2 I.meet + let widen = lift2 I.widen + let narrow = lift2 I.narrow + + let show x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + "⊤" + else + I.show x.v (* TODO add ikind to output *) + let pretty () x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + Pretty.text "⊤" + else + I.pretty () x.v (* TODO add ikind to output *) + let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) + let printXml o x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + BatPrintf.fprintf o "\n\n⊤\n\n\n" + else + I.printXml o x.v (* TODO add ikind to output *) + (* This is for debugging *) + let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" + let to_yojson x = I.to_yojson x.v + let invariant e x = + let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in + I.invariant_ikind e' x.ikind x.v + let tag x = I.tag x.v + let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." + let to_int x = I.to_int x.v + let of_int ikind x = { v = I.of_int ikind x; ikind} + let equal_to i x = I.equal_to i x.v + let to_bool x = I.to_bool x.v + let of_bool ikind b = { v = I.of_bool ikind b; ikind} + let to_excl_list x = I.to_excl_list x.v + let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} + let is_excl_list x = I.is_excl_list x.v + let to_incl_list x = I.to_incl_list x.v + let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} + let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} + let of_bitfield ikind (z,o) = {v = I.of_bitfield ikind (z,o); ikind} + let to_bitfield ikind x = I.to_bitfield ikind x.v + + let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} + let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} + let maximal x = I.maximal x.v + let minimal x = I.minimal x.v + + let neg = lift I.neg + let add = lift2 I.add + let sub = lift2 I.sub + let mul = lift2 I.mul + let div = lift2 I.div + let rem = lift2 I.rem + let lt = lift2_cmp I.lt + let gt = lift2_cmp I.gt + let le = lift2_cmp I.le + let ge = lift2_cmp I.ge + let eq = lift2_cmp I.eq + let ne = lift2_cmp I.ne + let lognot = lift I.lognot + let logand = lift2 I.logand + let logor = lift2 I.logor + let logxor = lift2 I.logxor + let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) + let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) + let c_lognot = lift_logical I.c_lognot + let c_logand = lift2 I.c_logand + let c_logor = lift2 I.c_logor + + let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} + + let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v + + let relift x = { v = I.relift x.v; ikind = x.ikind } + + let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } +end + +module type Ikind = +sig + val ikind: unit -> Cil.ikind +end + +module PtrDiffIkind : Ikind = +struct + let ikind = Cilfacade.ptrdiff_ikind +end + +module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = +struct + include I + let top () = I.top_of (Ik.ikind ()) + let bot () = I.bot_of (Ik.ikind ()) +end + +module Size = struct (* size in bits as int, range as int64 *) + open Cil + let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned + + let top_typ = TInt (ILongLong, []) + let min_for x = intKindForValue x (sign x = `Unsigned) + let bit = function (* bits needed for representation *) + | IBool -> 1 + | ik -> bytesSizeOfInt ik * 8 + let is_int64_big_int x = Z.fits_int64 x + let card ik = (* cardinality *) + let b = bit ik in + Z.shift_left Z.one b + let bits ik = (* highest bits for neg/pos values *) + let s = bit ik in + if isSigned ik then s-1, s-1 else 0, s + let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) + let range ik = + let a,b = bits ik in + let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in + let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) + x,y + + let is_cast_injective ~from_type ~to_type = + let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in + let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in + if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; + Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 + + let cast t x = (* TODO: overflow is implementation-dependent! *) + if t = IBool then + (* C11 6.3.1.2 Boolean type *) + if Z.equal x Z.zero then Z.zero else Z.one + else + let a,b = range t in + let c = card t in + let y = Z.erem x c in + let y = if Z.gt y b then Z.sub y c + else if Z.lt y a then Z.add y c + else y + in + if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); + y + + let min_range_sign_agnostic x = + let size ik = + let a,b = bits_i64 ik in + Int64.neg a,b + in + if sign x = `Signed then + size (min_for x) + else + let a, b = size (min_for x) in + if b <= 64L then + let upper_bound_less = Int64.sub b 1L in + let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in + if x <= max_one_less then + a, upper_bound_less + else + a,b + else + a, b + + (* From the number of bits used to represent a positive value, determines the maximal representable value *) + let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) + + (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) + let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) + +end + + +module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct + open B + (* these should be overwritten for better precision if possible: *) + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let of_bitfield ik x = top_of ik + let starting ?(suppress_ovwarn=false) ik x = top_of ik + let ending ?(suppress_ovwarn=false) ik x = top_of ik + let maximal x = None + let minimal x = None +end + +module Std (B: sig + type t + val name: unit -> string + val top_of: Cil.ikind -> t + val bot_of: Cil.ikind -> t + val show: t -> string + val equal: t -> t -> bool + end) = struct + include Printable.StdLeaf + let name = B.name (* overwrite the one from Printable.Std *) + open B + let is_top x = failwith "is_top not implemented for IntDomain.Std" + let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind + This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) + let is_top_of ik x = B.equal x (top_of ik) + + (* all output is based on B.show *) + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) + let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y + + include StdTop (B) +end + +(* Textbook interval arithmetic, without any overflow handling etc. *) +module IntervalArith (Ints_t : IntOps.IntOps) = struct + let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) + let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) + + let mul (x1, x2) (y1, y2) = + let x1y1 = (Ints_t.mul x1 y1) in + let x1y2 = (Ints_t.mul x1 y2) in + let x2y1 = (Ints_t.mul x2 y1) in + let x2y2 = (Ints_t.mul x2 y2) in + (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) + + let shift_left (x1,x2) (y1,y2) = + let y1p = Ints_t.shift_left Ints_t.one y1 in + let y2p = Ints_t.shift_left Ints_t.one y2 in + mul (x1, x2) (y1p, y2p) + + let div (x1, x2) (y1, y2) = + let x1y1n = (Ints_t.div x1 y1) in + let x1y2n = (Ints_t.div x1 y2) in + let x2y1n = (Ints_t.div x2 y1) in + let x2y2n = (Ints_t.div x2 y2) in + let x1y1p = (Ints_t.div x1 y1) in + let x1y2p = (Ints_t.div x1 y2) in + let x2y1p = (Ints_t.div x2 y1) in + let x2y2p = (Ints_t.div x2 y2) in + (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) + + let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) + let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) + + let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) + + let one = (Ints_t.one, Ints_t.one) + let zero = (Ints_t.zero, Ints_t.zero) + let top_bool = (Ints_t.zero, Ints_t.one) + + let to_int (x1, x2) = + if Ints_t.equal x1 x2 then Some x1 else None + + let upper_threshold u max_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + let max_ik' = Ints_t.to_bigint max_ik in + let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in + BatOption.map_default Ints_t.of_bigint max_ik t + let lower_threshold l min_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + let min_ik' = Ints_t.to_bigint min_ik in + let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in + BatOption.map_default Ints_t.of_bigint min_ik t + let is_upper_threshold u = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + List.exists (Z.equal u) ts + let is_lower_threshold l = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + List.exists (Z.equal l) ts +end + +module IntInvariant = +struct + let of_int e ik x = + if get_bool "witness.invariant.exact" then + Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) + else + Invariant.none + + let of_incl_list e ik ps = + match ps with + | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> + assert (List.mem Z.zero ps); + assert (List.mem Z.one ps); + Invariant.none + | [_] when get_bool "witness.invariant.exact" -> + Invariant.none + | _ :: _ :: _ + | [_] | [] -> + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in + Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) (Invariant.bot ()) ps + + let of_interval_opt e ik = function + | (Some x1, Some x2) when Z.equal x1 x2 -> + of_int e ik x1 + | x1_opt, x2_opt -> + let (min_ik, max_ik) = Size.range ik in + let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in + let i1 = + match x1_opt, inexact_type_bounds with + | Some x1, false when Z.equal min_ik x1 -> Invariant.none + | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) + | None, _ -> Invariant.none + in + let i2 = + match x2_opt, inexact_type_bounds with + | Some x2, false when Z.equal x2 max_ik -> Invariant.none + | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) + | None, _ -> Invariant.none + in + Invariant.(i1 && i2) + + let of_interval e ik (x1, x2) = + of_interval_opt e ik (Some x1, Some x2) + + let of_excl_list e ik ns = + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in + Invariant.(a && i) + ) (Invariant.top ()) ns +end + +module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct + include D + + let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = fst @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = fst @@ D.shift_left ik x y + + let shift_right ik x y = fst @@ D.shift_right ik x y +end + +module IntIkind = struct let ikind () = Cil.IInt end + +module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) +struct + include Printable.Std + let name () = "integers" + type t = Ints_t.t [@@deriving eq, ord, hash] + type int_t = Ints_t.t + let top () = raise Unknown + let bot () = raise Error + let top_of ik = top () + let bot_of ik = bot () + let show (x: Ints_t.t) = Ints_t.to_string x + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) + let is_top _ = false + let is_bot _ = false + + let equal_to i x = if i > x then `Neq else `Top + let leq x y = x <= y + let join x y = if Ints_t.compare x y > 0 then x else y + let widen = join + let meet x y = if Ints_t.compare x y > 0 then y else x + let narrow = meet + + let of_bool x = if x then Ints_t.one else Ints_t.zero + let to_bool' x = x <> Ints_t.zero + let to_bool x = Some (to_bool' x) + let of_int x = x + let to_int x = Some x + + let neg = Ints_t.neg + let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) + let sub = Ints_t.sub + let mul = Ints_t.mul + let div = Ints_t.div + let rem = Ints_t.rem + let lt n1 n2 = of_bool (n1 < n2) + let gt n1 n2 = of_bool (n1 > n2) + let le n1 n2 = of_bool (n1 <= n2) + let ge n1 n2 = of_bool (n1 >= n2) + let eq n1 n2 = of_bool (n1 = n2) + let ne n1 n2 = of_bool (n1 <> n2) + let lognot = Ints_t.lognot + let logand = Ints_t.logand + let logor = Ints_t.logor + let logxor = Ints_t.logxor + let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) + let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) + let c_lognot n1 = of_bool (not (to_bool' n1)) + let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) + let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) + let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." + let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) + let invariant _ _ = Invariant.none (* TODO *) +end + +module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) +struct + include Integers(IntOps.Int64Ops) + let top () = raise Unknown + let bot () = raise Error + let leq = equal + let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y + let join x y = if equal x y then x else top () + let meet x y = if equal x y then x else bot () +end + +module Flat (Base: IkindUnawareS): IkindUnawareS with type t = [ `Bot | `Lifted of Base.t | `Top ] and type int_t = Base.int_t = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) +struct + type int_t = Base.int_t + include Lattice.FlatConf (struct + include Printable.DefaultConf + let top_name = "Unknown int" + let bot_name = "Error int" + end) (Base) + + let top_of ik = top () + let bot_of ik = bot () + + + let name () = "flat integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let of_bitfield ik x = top_of ik + let starting ?(suppress_ovwarn=false) ikind x = top_of ikind + let ending ?(suppress_ovwarn=false) ikind x = top_of ikind + let maximal x = None + let minimal x = None + + let lift1 f x = match x with + | `Lifted x -> + (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> + (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Lift (Base: IkindUnawareS): IkindUnawareS with type t = [ `Bot | `Lifted of Base.t | `Top ] and type int_t = Base.int_t = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) +struct + include Lattice.LiftPO (struct + include Printable.DefaultConf + let top_name = "MaxInt" + let bot_name = "MinInt" + end) (Base) + type int_t = Base.int_t + let top_of ik = top () + let bot_of ik = bot () + include StdTop (struct type nonrec t = t let top_of = top_of end) + + let name () = "lifted integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let lift1 f x = match x with + | `Lifted x -> `Lifted (f x) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> `Lifted (f x y) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Flattened = Flat (Integers (IntOps.Int64Ops)) +module Lifted = Lift (Integers (IntOps.Int64Ops)) + +module Reverse (Base: IkindUnawareS) = +struct + include Base + include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) +end + +module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct + + include D + + let lift v = (v, {overflow=false; underflow=false}) + + let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = lift @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = lift @@ D.shift_left ik x y + + let shift_right ik x y = lift @@ D.shift_right ik x y + +end From 57ac94af1455faeaa7c248d399c08af8de0ac9f7 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 17 Dec 2024 16:40:04 +0100 Subject: [PATCH 101/111] merge --- tests/unit/cdomains/intDomainTest.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index ca39a68478..70b11185bd 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -574,6 +574,10 @@ struct "property_test_shift_left" >::: test_shift_left; "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); + assert_shift_left ik_uint (`I [1]) (`I [32]) (top); + assert_shift_left ik_uint (`I [1]) (`I [31]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [31]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [31; 0]) (`I [2147483648; 1]); List.iter (fun ik -> assert_shift_left ik bot (`I [1]) bot; From 6c7f899debd749dcb6be9411ee927172144b7f88 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 17 Dec 2024 16:43:14 +0100 Subject: [PATCH 102/111] exclude bitfield in modules python script as other intdomains --- scripts/goblint-lib-modules.py | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 90537e57fe..0e0a0613a7 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -53,6 +53,7 @@ "DefExcDomain", # included in IntDomain "EnumsDomain", # included in IntDomain "CongruenceDomain", # included in IntDomain + "BitfieldDomain", #included in IntDomain "IntDomTuple", # included in IntDomain "WitnessGhostVar", # included in WitnessGhost From 313adb8e90a928103b1e3fa8556664389f82251a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 17 Dec 2024 17:03:25 +0100 Subject: [PATCH 103/111] changed to top_of --- src/cdomain/value/cdomains/int/bitfieldDomain.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/cdomain/value/cdomains/int/bitfieldDomain.ml b/src/cdomain/value/cdomains/int/bitfieldDomain.ml index 7ad2f3be69..18d6da1b87 100644 --- a/src/cdomain/value/cdomains/int/bitfieldDomain.ml +++ b/src/cdomain/value/cdomains/int/bitfieldDomain.ml @@ -226,8 +226,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let (min_ik, max_ik) = Size.range ik in let isPos = z < Ints_t.zero in let isNeg = o < Ints_t.zero in - let underflow = if isSigned ik then (((Ints_t.of_bigint min_ik) &: z) <> Ints_t.zero) && isNeg else isNeg in - + let underflow = if isSigned ik then (((Ints_t.of_bigint min_ik) &: z) <> Ints_t.zero) && isNeg else isNeg in let overflow = (((!: (Ints_t.of_bigint max_ik)) &: o) <> Ints_t.zero) && isPos in let new_bitfield = wrap ik (z,o) in @@ -241,7 +240,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (* (bot (), overflow_info)) *) (top_of ik, overflow_info)) else - (top (), overflow_info) + (top_of ik, overflow_info) let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t @@ -375,7 +374,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (bot (), {underflow=false; overflow=false}) else if is_undefined_shift_operation ik a b then - (top (), {underflow=false; overflow=false}) + (top_of ik, {underflow=false; overflow=false}) else norm ik @@ BArith.shift_right ik a (exclude_undefined_bitshifts ik b) @@ -386,7 +385,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (bot (), {underflow=false; overflow=false}) else if is_undefined_shift_operation ik a b then - (top (), {underflow=false; overflow=false}) + (top_of ik, {underflow=false; overflow=false}) else norm ik @@ BArith.shift_left ik a (exclude_undefined_bitshifts ik b) @@ -436,7 +435,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int norm ik (z3, o3) let neg ?no_ov ik x = - M.trace "bitfield" "neg"; + if M.tracing then M.trace "bitfield" "neg"; sub ?no_ov ik BArith.zero x let mul ?no_ov ik (z1, o1) (z2, o2) = From ee9f3589dc1fcd19f0159ac0d353912b17a415c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 17 Dec 2024 17:06:46 +0100 Subject: [PATCH 104/111] merge --- tests/unit/cdomains/intDomainTest.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index ca39a68478..70b11185bd 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -574,6 +574,10 @@ struct "property_test_shift_left" >::: test_shift_left; "shift_left_edge_cases" >:: fun _ -> assert_shift_left ik (`I [1]) (`I [1; 2]) (`I [1; 2; 4; 8]); + assert_shift_left ik_uint (`I [1]) (`I [32]) (top); + assert_shift_left ik_uint (`I [1]) (`I [31]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [31]) (`I [2147483648]); + assert_shift_left ik (`I [1]) (`I [31; 0]) (`I [2147483648; 1]); List.iter (fun ik -> assert_shift_left ik bot (`I [1]) bot; From 306aa330f4fcf1aac370812395610c913a3a6fc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Tue, 17 Dec 2024 17:46:01 +0100 Subject: [PATCH 105/111] improved refinements with bitfield --- src/cdomain/value/cdomains/int/bitfieldDomain.ml | 2 +- .../value/cdomains/int/congruenceDomain.ml | 4 +++- src/cdomain/value/cdomains/int/defExcDomain.ml | 10 +++++++--- src/cdomain/value/cdomains/int/enumsDomain.ml | 12 ++++++++++-- src/cdomain/value/cdomains/int/intervalDomain.ml | 15 +++++++++++++-- 5 files changed, 34 insertions(+), 9 deletions(-) diff --git a/src/cdomain/value/cdomains/int/bitfieldDomain.ml b/src/cdomain/value/cdomains/int/bitfieldDomain.ml index 18d6da1b87..af81b21c41 100644 --- a/src/cdomain/value/cdomains/int/bitfieldDomain.ml +++ b/src/cdomain/value/cdomains/int/bitfieldDomain.ml @@ -227,7 +227,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let isPos = z < Ints_t.zero in let isNeg = o < Ints_t.zero in let underflow = if isSigned ik then (((Ints_t.of_bigint min_ik) &: z) <> Ints_t.zero) && isNeg else isNeg in - let overflow = (((!: (Ints_t.of_bigint max_ik)) &: o) <> Ints_t.zero) && isPos in + let overflow = (((!:(Ints_t.of_bigint max_ik)) &: o) <> Ints_t.zero) && isPos in let new_bitfield = wrap ik (z,o) in let overflow_info = if suppress_ovwarn then {underflow=false; overflow=false} else {underflow=underflow; overflow=overflow} in diff --git a/src/cdomain/value/cdomains/int/congruenceDomain.ml b/src/cdomain/value/cdomains/int/congruenceDomain.ml index 964485acee..549f1b5059 100644 --- a/src/cdomain/value/cdomains/int/congruenceDomain.ml +++ b/src/cdomain/value/cdomains/int/congruenceDomain.ml @@ -500,7 +500,9 @@ struct refn let refine_with_congruence ik a b = meet ik a b - let refine_with_bitfield ik a b = a + let refine_with_bitfield ik a (z,o) = + if Z.lognot z = o then meet ik a (Some (o, Z.zero)) + else a let refine_with_excl_list ik a b = a let refine_with_incl_list ik a b = a diff --git a/src/cdomain/value/cdomains/int/defExcDomain.ml b/src/cdomain/value/cdomains/int/defExcDomain.ml index 1df48ba141..38921e16c8 100644 --- a/src/cdomain/value/cdomains/int/defExcDomain.ml +++ b/src/cdomain/value/cdomains/int/defExcDomain.ml @@ -300,8 +300,10 @@ struct norm ik @@ (`Excluded (ex, r)) let to_bitfield ik x = - let one_mask = Z.lognot Z.zero - in (one_mask, one_mask) + match x with + `Definite c -> (Z.lognot c, c) | + _ -> let one_mask = Z.lognot Z.zero + in (one_mask, one_mask) let starting ?(suppress_ovwarn=false) ikind x = let _,u_ik = Size.range ikind in @@ -534,7 +536,9 @@ struct ] (* S TODO: decide frequencies *) let refine_with_congruence ik a b = a - let refine_with_bitfield ik x y = x + let refine_with_bitfield ik x (z,o) = + if Z.lognot z = o then meet ik x (`Definite o) + else x let refine_with_interval ik a b = match a, b with | x, Some(i) -> meet ik x (of_interval ik i) | _ -> a diff --git a/src/cdomain/value/cdomains/int/enumsDomain.ml b/src/cdomain/value/cdomains/int/enumsDomain.ml index b169f299d2..29497e3f31 100644 --- a/src/cdomain/value/cdomains/int/enumsDomain.ml +++ b/src/cdomain/value/cdomains/int/enumsDomain.ml @@ -251,7 +251,13 @@ module Enums : S with type int_t = Z.t = struct let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None let to_bitfield ik x = - let one_mask = Z.lognot Z.zero + match x with + Inc i when BISet.is_empty i -> (Z.zero, Z.zero) | + Inc i when BISet.is_singleton i -> + let o = BISet.choose i + in (Z.lognot o, o) | + Inc i -> BISet.fold (fun o (az, ao) -> (Z.logor (Z.lognot o) az, Z.logor o ao)) i (Z.zero, Z.zero) | + _ -> let one_mask = Z.lognot Z.zero in (one_mask, one_mask) let starting ?(suppress_ovwarn=false) ikind x = @@ -360,7 +366,9 @@ module Enums : S with type int_t = Z.t = struct | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) | _ -> a - let refine_with_bitfield ik x y = x + let refine_with_bitfield ik x (z,o) = + if Z.lognot z = o then meet ik x (Inc (BISet.singleton o)) + else x let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) diff --git a/src/cdomain/value/cdomains/int/intervalDomain.ml b/src/cdomain/value/cdomains/int/intervalDomain.ml index bef586dbb7..c7c281fe9e 100644 --- a/src/cdomain/value/cdomains/int/intervalDomain.ml +++ b/src/cdomain/value/cdomains/int/intervalDomain.ml @@ -106,7 +106,18 @@ struct let (min_ik, max_ik) = Size.range ik in let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in - + + let wrap ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (Ints_t.logand Ints_t.one (Ints_t.shift_right z (Size.bit ik - 1)))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (Ints_t.logand Ints_t.one (Ints_t.shift_right o (Size.bit ik - 1)))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo) + in let rec analyze_bits pos (acc_z, acc_o) = if pos < 0 then (acc_z, acc_o) else @@ -138,7 +149,7 @@ struct in let result = analyze_bits (Size.bit ik - 1) (Ints_t.zero, Ints_t.zero) in let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) - in casted + in wrap ik casted let of_bool _ik = function true -> one | false -> zero let to_bool (a: t) = match a with From 3862f2ed6c2eebfcb2e4133506d30b6999d5d2f8 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 17 Dec 2024 17:49:43 +0100 Subject: [PATCH 106/111] added overflow checking --- src/cdomain/value/cdomains/int/intDomTuple.ml | 21 +++++++++++-------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/cdomain/value/cdomains/int/intDomTuple.ml b/src/cdomain/value/cdomains/int/intDomTuple.ml index 74072b80a6..cfe9d5caf5 100644 --- a/src/cdomain/value/cdomains/int/intDomTuple.ml +++ b/src/cdomain/value/cdomains/int/intDomTuple.ml @@ -63,13 +63,14 @@ module IntDomTupleImpl = struct | Some(_, {underflow; overflow}) -> not (underflow || overflow) | _ -> false - let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = - let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in - if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( + let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set bf = + let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) || (no_overflow ik bf) in + if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set || BatOption.is_some bf) then ( let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in - let underflow = underflow_intv && underflow_intv_set in - let overflow = overflow_intv && overflow_intv_set in + let (_,{underflow=underflow_bf; overflow=overflow_bf}) = match bf with None -> (I6.bot (), {underflow= true; overflow = true}) | Some x -> x in + let underflow = underflow_intv && underflow_intv_set && underflow_bf in + let overflow = overflow_intv && overflow_intv_set && overflow_bf in set_overflow_flag ~cast ~underflow ~overflow ik; ); no_ov @@ -308,7 +309,8 @@ module IntDomTupleImpl = struct let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in let intv = map (r.f1_ovc (module I2)) b in let intv_set = map (r.f1_ovc (module I5)) e in - let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in + let bf = map (r.f1_ovc (module I6)) f in + let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set bf in let no_ov = no_ov || should_ignore_overflow ik in refine ik ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a @@ -316,13 +318,14 @@ module IntDomTupleImpl = struct , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d , BatOption.map fst intv_set - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I6) x |> fst) f) + , BatOption.map fst bf) (* map2 with overflow check *) let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe, xf) (ya, yb, yc, yd, ye, yf) = let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in - let no_ov = check_ov ~cast ik intv intv_set in + let bf = opt_map2 (r.f2_ovc (module I6)) xf yf in + let no_ov = check_ov ~cast ik intv intv_set bf in let no_ov = no_ov || should_ignore_overflow ik in refine ik ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya @@ -330,7 +333,7 @@ module IntDomTupleImpl = struct , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd , BatOption.map fst intv_set - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I6) x y |> fst) xf yf) + , BatOption.map fst bf) let map ik r (a, b, c, d, e, f) = refine ik From b6838753bc6855698d286bf6cf73033f92604d04 Mon Sep 17 00:00:00 2001 From: leon Date: Tue, 17 Dec 2024 17:51:48 +0100 Subject: [PATCH 107/111] added missing bf in create --- src/cdomain/value/cdomains/int/intDomTuple.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/int/intDomTuple.ml b/src/cdomain/value/cdomains/int/intDomTuple.ml index cfe9d5caf5..de4486b10e 100644 --- a/src/cdomain/value/cdomains/int/intDomTuple.ml +++ b/src/cdomain/value/cdomains/int/intDomTuple.ml @@ -80,7 +80,8 @@ module IntDomTupleImpl = struct let map x = Option.map fst x in let intv = f p2 @@ r.fi2_ovc (module I2) in let intv_set = f p5 @@ r.fi2_ovc (module I5) in - ignore (check_ov ~cast:false ik intv intv_set); + let bf = f p6 @@ r.fi2_ovc (module I6) in + ignore (check_ov ~cast:false ik intv intv_set bf); map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) , map @@ f p6 @@ r.fi2_ovc (module I6) let create2_ovc ik r x = (* use where values are introduced *) From 26a23f5361b95a98b6260c222bdd8f286b3336d8 Mon Sep 17 00:00:00 2001 From: iC4rl0s <93283755+iC4rl0s@users.noreply.github.com> Date: Tue, 17 Dec 2024 18:57:53 +0100 Subject: [PATCH 108/111] bugfixes for overflow errs --- src/cdomain/value/cdomains/intDomain.ml | 14 +++++++++----- tests/unit/cdomains/intDomainTest.ml | 8 ++++---- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 80d570f341..786c7acba0 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1226,7 +1226,9 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let concretize bf = List.map Ints_t.to_int (concretize bf) let shift_right ik (z,o) c = - let sign_mask = !:(bitmask_up_to (Size.bit ik - c)) in + let msb_pos = (Size.bit ik - c) in + let msb_pos = if msb_pos < 0 then 0 else msb_pos in + let sign_mask = !:(bitmask_up_to msb_pos) in if isSigned ik && o <: Ints_t.zero then (z >>: c, (o >>: c) |: sign_mask) else @@ -1472,8 +1474,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let lognot ik i1 = BArith.lognot i1 |> norm ik |> fst let precision ik = snd @@ Size.bits ik - let exclude_undefined_bitshifts ik (z,o) = - let mask = BArith.bitmask_up_to (Z.log2up @@ Z.of_int @@ precision ik) in + let cap_bitshifts_to_precision ik (z,o) = + let mask = BArith.bitmask_up_to (Int.succ @@ Z.log2up @@ Z.of_int @@ precision ik) in (z |: !:mask, o &: mask) let is_invalid_shift_operation ik a b = BArith.is_invalid b @@ -1493,7 +1495,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int then (top (), {underflow=false; overflow=false}) else - norm ik @@ BArith.shift_right ik a (exclude_undefined_bitshifts ik b) + let defined_shifts = cap_bitshifts_to_precision ik b in + norm ik @@ BArith.shift_right ik a defined_shifts let shift_left ik a b = if M.tracing then M.trace "bitfield" "%a << %a" pretty a pretty b; @@ -1504,7 +1507,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int then (top (), {underflow=false; overflow=false}) else - norm ik @@ BArith.shift_left ik a (exclude_undefined_bitshifts ik b) + let defined_shifts = cap_bitshifts_to_precision ik b in + norm ik @@ (BArith.shift_left ik a defined_shifts) (* Arith *) diff --git a/tests/unit/cdomains/intDomainTest.ml b/tests/unit/cdomains/intDomainTest.ml index ca39a68478..1b6b963f4f 100644 --- a/tests/unit/cdomains/intDomainTest.ml +++ b/tests/unit/cdomains/intDomainTest.ml @@ -599,8 +599,8 @@ struct ) else ( (* See C11 N2310 at 6.5.7 *) assert_shift_left ik (`I [1]) (`I [under_precision ik]) (`I [highest_bit_set ik]); - assert_shift_left ik (`I [1]) (`I [precision ik]) (`I [1]); - assert_shift_left ik (`I [1]) (`I [over_precision ik]) (`I [2]); + assert_shift_left ik (`I [1]) (`I [precision ik]) (`I [0]); + assert_shift_left ik (`I [1]) (`I [over_precision ik]) (`I [0]); ) ) ik_lst @@ -637,8 +637,8 @@ struct ) else ( (* See C11 N2310 at 6.5.7 *) assert_shift_right ik (`I [max_of ik]) (`I [under_precision ik]) (`I [1]); - assert_shift_right ik (`I [max_of ik]) (`I [precision ik]) (`I [0]); (* TODO fails due to wrong overflow handling? *) - assert_shift_right ik (`I [max_of ik]) (`I [over_precision ik]) (`I [0]); (* TODO fails due to wrong overflow handling? *) + assert_shift_right ik (`I [max_of ik]) (`I [precision ik]) (`I [0]); + assert_shift_right ik (`I [max_of ik]) (`I [over_precision ik]) (`I [0]); ) ) ik_lst From 898a68e819c41d99a065642c75ca3b0c28d81d3a Mon Sep 17 00:00:00 2001 From: leon Date: Wed, 18 Dec 2024 12:34:20 +0100 Subject: [PATCH 109/111] fixed all current ocp-indent failures --- .../value/cdomains/int/bitfieldDomain.ml | 104 +++++++++--------- .../value/cdomains/int/congruenceDomain.ml | 14 +-- .../value/cdomains/int/defExcDomain.ml | 6 +- src/cdomain/value/cdomains/int/enumsDomain.ml | 10 +- .../value/cdomains/int/intervalDomain.ml | 90 +++++++-------- .../value/cdomains/int/intervalSetDomain.ml | 14 +-- src/cdomain/value/util/precisionUtil.ml | 2 +- 7 files changed, 120 insertions(+), 120 deletions(-) diff --git a/src/cdomain/value/cdomains/int/bitfieldDomain.ml b/src/cdomain/value/cdomains/int/bitfieldDomain.ml index d0c65284fd..bb850b6aa5 100644 --- a/src/cdomain/value/cdomains/int/bitfieldDomain.ml +++ b/src/cdomain/value/cdomains/int/bitfieldDomain.ml @@ -78,7 +78,7 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let bitmask_up_to pos = let top_bit = Ints_t.one <<: pos in if top_bit =: Ints_t.zero - then Ints_t.zero + then Ints_t.zero else Ints_t.sub top_bit Ints_t.one @@ -122,13 +122,13 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let shift_right ik (z1, o1) (z2, o2) = if is_const (z2, o2) - then - shift_right ik (z1, o1) (Ints_t.to_int o2) + then + shift_right ik (z1, o1) (Ints_t.to_int o2) else let shift_counts = concretize (z2, o2) in List.fold_left (fun acc c -> - let next = shift_right ik (z1, o1) c in join acc next - ) (zero_mask, zero_mask) shift_counts + let next = shift_right ik (z1, o1) c in join acc next + ) (zero_mask, zero_mask) shift_counts let shift_left _ (z,o) c = let zero_mask = bitmask_up_to c in @@ -136,13 +136,13 @@ module BitfieldArith (Ints_t : IntOps.IntOps) = struct let shift_left ik (z1, o1) (z2, o2) = if is_const (z2, o2) - then - shift_left ik (z1, o1) (Ints_t.to_int o2) + then + shift_left ik (z1, o1) (Ints_t.to_int o2) else let shift_counts = concretize (z2, o2) in List.fold_left (fun acc c -> - let next = shift_left ik (z1, o1) c in join acc next - ) (zero_mask, zero_mask) shift_counts + let next = shift_left ik (z1, o1) c in join acc next + ) (zero_mask, zero_mask) shift_counts end module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) = struct @@ -161,7 +161,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let top_of ik = if isSigned ik then top () else (BArith.one_mask, Ints_t.of_bigint (snd (Size.range ik))) - + let bot_of ik = bot () let to_pretty_bits (z,o) = @@ -171,25 +171,25 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let z_mask = ref z in let rec to_pretty_bits' acc = - let current_bit_known = (!known_bitmask &: Ints_t.one) = Ints_t.one in - let current_bit_impossible = (!invalid_bitmask &: Ints_t.one) = Ints_t.one in - - let bit_value = !o_mask &: Ints_t.one in - let bit = - if current_bit_impossible then "⊥" - else if not current_bit_known then "⊤" - else Ints_t.to_string bit_value - in + let current_bit_known = (!known_bitmask &: Ints_t.one) = Ints_t.one in + let current_bit_impossible = (!invalid_bitmask &: Ints_t.one) = Ints_t.one in + + let bit_value = !o_mask &: Ints_t.one in + let bit = + if current_bit_impossible then "⊥" + else if not current_bit_known then "⊤" + else Ints_t.to_string bit_value + in - if (!o_mask = Ints_t.of_int (-1) || !o_mask = Ints_t.zero ) && (!z_mask = Ints_t.of_int (-1) || !z_mask = Ints_t.zero) then - let prefix = bit ^ "..." ^ bit in - prefix ^ acc - else - (known_bitmask := !known_bitmask >>: 1; - invalid_bitmask := !invalid_bitmask >>: 1; - o_mask := !o_mask >>: 1; - z_mask := !z_mask >>: 1; - to_pretty_bits' (bit ^ acc)) + if (!o_mask = Ints_t.of_int (-1) || !o_mask = Ints_t.zero ) && (!z_mask = Ints_t.of_int (-1) || !z_mask = Ints_t.zero) then + let prefix = bit ^ "..." ^ bit in + prefix ^ acc + else + (known_bitmask := !known_bitmask >>: 1; + invalid_bitmask := !invalid_bitmask >>: 1; + o_mask := !o_mask >>: 1; + z_mask := !z_mask >>: 1; + to_pretty_bits' (bit ^ acc)) in "0b" ^ to_pretty_bits' "" @@ -197,12 +197,12 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int if t = bot () then "bot" else if t = top () then "top" else let (z,o) = t in - Format.sprintf "{%s, (zs:%s, os:%s)}" (to_pretty_bits t) (Ints_t.to_string z) (Ints_t.to_string o) + Format.sprintf "{%s, (zs:%s, os:%s)}" (to_pretty_bits t) (Ints_t.to_string z) (Ints_t.to_string o) include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let range ik bf = (BArith.min ik bf, BArith.max ik bf) - + let maximal (z,o) = if (z < Ints_t.zero) <> (o < Ints_t.zero) then Some o else None @@ -240,8 +240,8 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (new_bitfield, overflow_info) else if should_ignore_overflow ik then (M.warn ~category:M.Category.Integer.overflow "Bitfield: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Top"; - (* (bot (), overflow_info)) *) - (top_of ik, overflow_info)) + (* (bot (), overflow_info)) *) + (top_of ik, overflow_info)) else (top_of ik, overflow_info) @@ -274,7 +274,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let (min_ik, max_ik) = Size.range ik in let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in - + let rec analyze_bits pos (acc_z, acc_o) = if pos < 0 then (acc_z, acc_o) else @@ -284,15 +284,15 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let without_remainder = Ints_t.sub startv remainder in let bigger_number = Ints_t.add without_remainder position in - + let bit_status = if Ints_t.compare bigger_number endv <= 0 then `top else - if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then - `one - else - `zero + if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then + `one + else + `zero in let new_acc = @@ -365,7 +365,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int (z |: !:mask, o &: mask) let is_invalid_shift_operation ik a b = BArith.is_invalid b - || BArith.is_invalid a + || BArith.is_invalid a let is_undefined_shift_operation ik a b = let some_negatives = BArith.min ik b < Z.zero in @@ -375,11 +375,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_right ik a b = if M.tracing then M.trace "bitfield" "%a >> %a" pretty a pretty b; if is_invalid_shift_operation ik a b - then - (bot (), {underflow=false; overflow=false}) + then + (bot (), {underflow=false; overflow=false}) else if is_undefined_shift_operation ik a b - then - (top_of ik, {underflow=false; overflow=false}) + then + (top_of ik, {underflow=false; overflow=false}) else let defined_shifts = cap_bitshifts_to_precision ik b in norm ik @@ BArith.shift_right ik a defined_shifts @@ -387,11 +387,11 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let shift_left ik a b = if M.tracing then M.trace "bitfield" "%a << %a" pretty a pretty b; if is_invalid_shift_operation ik a b - then - (bot (), {underflow=false; overflow=false}) + then + (bot (), {underflow=false; overflow=false}) else if is_undefined_shift_operation ik a b - then - (top_of ik, {underflow=false; overflow=false}) + then + (top_of ik, {underflow=false; overflow=false}) else let defined_shifts = cap_bitshifts_to_precision ik b in norm ik @@ BArith.shift_left ik a defined_shifts @@ -461,10 +461,10 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int let signBitDefZ = !:(o1 ^: o2) &: bitmask in for _ = size downto 0 do (if !pm &: Ints_t.one == Ints_t.one then - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (!qv |: !qm)) - else if !pv &: Ints_t.one == Ints_t.one then - accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); - accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero (!qv |: !qm)) + else if !pv &: Ints_t.one == Ints_t.one then + accv := fst(add_paper !accv Ints_t.zero !qv Ints_t.zero); + accm := snd(add_paper Ints_t.zero !accm Ints_t.zero !qm)); pv := !pv >>: 1; pm := !pm >>: 1; @@ -586,7 +586,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int QCheck.(set_shrink shrink @@ set_print show @@ map (fun (i1,i2) -> norm ik (i1,i2) |> fst ) pair_arb) let project ik p t = t - + end module Bitfield = BitfieldFunctor (IntOps.BigIntOps) \ No newline at end of file diff --git a/src/cdomain/value/cdomains/int/congruenceDomain.ml b/src/cdomain/value/cdomains/int/congruenceDomain.ml index 549f1b5059..41d2c8954f 100644 --- a/src/cdomain/value/cdomains/int/congruenceDomain.ml +++ b/src/cdomain/value/cdomains/int/congruenceDomain.ml @@ -142,13 +142,13 @@ struct let to_bitfield ik x = let is_power_of_two x = (Z.logand x (x -: Z.one) = Z.zero) in match x with None -> (Z.zero, Z.zero) | Some (c,m) -> - if m = Z.zero then (Z.lognot c, c) - else if is_power_of_two m then - let mod_mask = m -: Z.one in - let z = Z.lognot c in - let o = Z.logor (Z.lognot mod_mask) c in - (z,o) - else (Z.lognot Z.zero, Z.lognot Z.zero) + if m = Z.zero then (Z.lognot c, c) + else if is_power_of_two m then + let mod_mask = m -: Z.one in + let z = Z.lognot c in + let o = Z.logor (Z.lognot mod_mask) c in + (z,o) + else (Z.lognot Z.zero, Z.lognot Z.zero) let maximal t = match t with | Some (x, y) when y =: Z.zero -> Some x diff --git a/src/cdomain/value/cdomains/int/defExcDomain.ml b/src/cdomain/value/cdomains/int/defExcDomain.ml index 38921e16c8..4dceda7ee7 100644 --- a/src/cdomain/value/cdomains/int/defExcDomain.ml +++ b/src/cdomain/value/cdomains/int/defExcDomain.ml @@ -299,11 +299,11 @@ struct let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in norm ik @@ (`Excluded (ex, r)) - let to_bitfield ik x = - match x with + let to_bitfield ik x = + match x with `Definite c -> (Z.lognot c, c) | _ -> let one_mask = Z.lognot Z.zero - in (one_mask, one_mask) + in (one_mask, one_mask) let starting ?(suppress_ovwarn=false) ikind x = let _,u_ik = Size.range ikind in diff --git a/src/cdomain/value/cdomains/int/enumsDomain.ml b/src/cdomain/value/cdomains/int/enumsDomain.ml index 29497e3f31..bf28af98a6 100644 --- a/src/cdomain/value/cdomains/int/enumsDomain.ml +++ b/src/cdomain/value/cdomains/int/enumsDomain.ml @@ -252,13 +252,13 @@ module Enums : S with type int_t = Z.t = struct let to_bitfield ik x = match x with - Inc i when BISet.is_empty i -> (Z.zero, Z.zero) | - Inc i when BISet.is_singleton i -> + Inc i when BISet.is_empty i -> (Z.zero, Z.zero) | + Inc i when BISet.is_singleton i -> let o = BISet.choose i in (Z.lognot o, o) | - Inc i -> BISet.fold (fun o (az, ao) -> (Z.logor (Z.lognot o) az, Z.logor o ao)) i (Z.zero, Z.zero) | - _ -> let one_mask = Z.lognot Z.zero - in (one_mask, one_mask) + Inc i -> BISet.fold (fun o (az, ao) -> (Z.logor (Z.lognot o) az, Z.logor o ao)) i (Z.zero, Z.zero) | + _ -> let one_mask = Z.lognot Z.zero + in (one_mask, one_mask) let starting ?(suppress_ovwarn=false) ikind x = let _,u_ik = Size.range ikind in diff --git a/src/cdomain/value/cdomains/int/intervalDomain.ml b/src/cdomain/value/cdomains/int/intervalDomain.ml index c7c281fe9e..3b48936bdd 100644 --- a/src/cdomain/value/cdomains/int/intervalDomain.ml +++ b/src/cdomain/value/cdomains/int/intervalDomain.ml @@ -89,11 +89,11 @@ struct if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) else Ints_t.lognot z in let max ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.of_bigint (snd (Size.range ik)) in - let isPositive = Ints_t.logand signBit z <> Ints_t.zero in - if isSigned ik && isPositive then Ints_t.logand signMask o - else o + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.logand signMask o + else o in fst (norm ik (Some (min ik x, max ik x))) let of_int ik (x: int_t) = of_interval ik (x,x) @@ -103,53 +103,53 @@ struct let to_bitfield ik z = match z with None -> (Ints_t.lognot Ints_t.zero, Ints_t.lognot Ints_t.zero) | Some (x,y) -> - let (min_ik, max_ik) = Size.range ik in - let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in - let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in - - let wrap ik (z,o) = let (min_ik, max_ik) = Size.range ik in - if isSigned ik then - let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (Ints_t.logand Ints_t.one (Ints_t.shift_right z (Size.bit ik - 1)))) in - let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (Ints_t.logand Ints_t.one (Ints_t.shift_right o (Size.bit ik - 1)))) in - (newz,newo) - else - let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in - let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in - (newz,newo) + let startv = Ints_t.max x (Ints_t.of_bigint min_ik) in + let endv= Ints_t.min y (Ints_t.of_bigint max_ik) in + + let wrap ik (z,o) = + let (min_ik, max_ik) = Size.range ik in + if isSigned ik then + let newz = Ints_t.logor (Ints_t.logand z (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (Ints_t.logand Ints_t.one (Ints_t.shift_right z (Size.bit ik - 1)))) in + let newo = Ints_t.logor (Ints_t.logand o (Ints_t.of_bigint max_ik)) (Ints_t.mul (Ints_t.of_bigint min_ik) (Ints_t.logand Ints_t.one (Ints_t.shift_right o (Size.bit ik - 1)))) in + (newz,newo) + else + let newz = Ints_t.logor z (Ints_t.lognot (Ints_t.of_bigint max_ik)) in + let newo = Ints_t.logand o (Ints_t.of_bigint max_ik) in + (newz,newo) in - let rec analyze_bits pos (acc_z, acc_o) = - if pos < 0 then (acc_z, acc_o) - else - let position = Ints_t.shift_left Ints_t.one pos in - let mask = Ints_t.sub position Ints_t.one in - let remainder = Ints_t.logand startv mask in - - let without_remainder = Ints_t.sub startv remainder in - let bigger_number = Ints_t.add without_remainder position in - - let bit_status = - if Ints_t.compare bigger_number endv <= 0 then - `top - else + let rec analyze_bits pos (acc_z, acc_o) = + if pos < 0 then (acc_z, acc_o) + else + let position = Ints_t.shift_left Ints_t.one pos in + let mask = Ints_t.sub position Ints_t.one in + let remainder = Ints_t.logand startv mask in + + let without_remainder = Ints_t.sub startv remainder in + let bigger_number = Ints_t.add without_remainder position in + + let bit_status = + if Ints_t.compare bigger_number endv <= 0 then + `top + else if Ints_t.equal (Ints_t.logand (Ints_t.shift_right startv pos) Ints_t.one) Ints_t.one then `one else `zero - in + in - let new_acc = - match bit_status with - | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) - | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) - | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) + let new_acc = + match bit_status with + | `top -> (Ints_t.logor position acc_z, Ints_t.logor position acc_o) + | `one -> (Ints_t.logand (Ints_t.lognot position) acc_z, Ints_t.logor position acc_o) + | `zero -> (Ints_t.logor position acc_z, Ints_t.logand (Ints_t.lognot position) acc_o) - in - analyze_bits (pos - 1) new_acc - in - let result = analyze_bits (Size.bit ik - 1) (Ints_t.zero, Ints_t.zero) in - let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) - in wrap ik casted + in + analyze_bits (pos - 1) new_acc + in + let result = analyze_bits (Size.bit ik - 1) (Ints_t.zero, Ints_t.zero) in + let casted = (Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (fst result)))), Ints_t.of_bigint (Size.cast ik ((Ints_t.to_bigint (snd result))))) + in wrap ik casted let of_bool _ik = function true -> one | false -> zero let to_bool (a: t) = match a with @@ -447,7 +447,7 @@ struct let refn = refine_with_congruence ik x y in if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; refn - + let refine_with_bitfield ik a b = let interv = of_bitfield ik b in meet ik a interv diff --git a/src/cdomain/value/cdomains/int/intervalSetDomain.ml b/src/cdomain/value/cdomains/int/intervalSetDomain.ml index 8b40fd5d11..c38dd3dd02 100644 --- a/src/cdomain/value/cdomains/int/intervalSetDomain.ml +++ b/src/cdomain/value/cdomains/int/intervalSetDomain.ml @@ -244,18 +244,18 @@ struct if isSigned ik && isNegative then Ints_t.logor signMask (Ints_t.lognot z) else Ints_t.lognot z in let max ik (z,o) = - let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in - let signMask = Ints_t.of_bigint (snd (Size.range ik)) in - let isPositive = Ints_t.logand signBit z <> Ints_t.zero in - if isSigned ik && isPositive then Ints_t.logand signMask o - else o + let signBit = Ints_t.shift_left Ints_t.one ((Size.bit ik) - 1) in + let signMask = Ints_t.of_bigint (snd (Size.range ik)) in + let isPositive = Ints_t.logand signBit z <> Ints_t.zero in + if isSigned ik && isPositive then Ints_t.logand signMask o + else o in fst (norm_interval ik (min ik x, max ik x)) let to_bitfield ik x = let joinbf (z1,o1) (z2,o2) = (Ints_t.logor z1 z2, Ints_t.logor o1 o2) in let rec from_list is acc = match is with - [] -> acc | - j::js -> from_list js (joinbf acc (Interval.to_bitfield ik (Some j))) + [] -> acc | + j::js -> from_list js (joinbf acc (Interval.to_bitfield ik (Some j))) in from_list x (Ints_t.zero, Ints_t.zero) let of_int ik (x: int_t) = of_interval ik (x, x) diff --git a/src/cdomain/value/util/precisionUtil.ml b/src/cdomain/value/util/precisionUtil.ml index 9f27f810c7..a72a79aab3 100644 --- a/src/cdomain/value/util/precisionUtil.ml +++ b/src/cdomain/value/util/precisionUtil.ml @@ -68,7 +68,7 @@ let int_precision_from_fundec (fd: GoblintCil.fundec): int_precision = (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_enums ()) ~removeAttr:"no-enums" ~keepAttr:"enums" fd), (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_congruence ()) ~removeAttr:"no-congruence" ~keepAttr:"congruence" fd), (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_interval_set ()) ~removeAttr:"no-interval_set" ~keepAttr:"interval_set" fd), - (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_bitfield ()) ~removeAttr:"no-bitfield" ~keepAttr:"bitfield" fd)) + (ContextUtil.should_keep_int_domain ~isAttr:GobPrecision ~keepOption:(get_bitfield ()) ~removeAttr:"no-bitfield" ~keepAttr:"bitfield" fd)) let float_precision_from_fundec (fd: GoblintCil.fundec): float_precision = ((ContextUtil.should_keep ~isAttr:GobPrecision ~keepOption:"ana.float.interval" ~removeAttr:"no-float-interval" ~keepAttr:"float-interval" fd)) From 0cc16dc5abc2d4498c9c0724fd2756db14db551d Mon Sep 17 00:00:00 2001 From: leon Date: Thu, 19 Dec 2024 15:51:42 +0100 Subject: [PATCH 110/111] added regression test --- src/cdomain/value/util/precisionUtil.ml | 5 ++- tests/regression/82-bitfield/12-precision.c | 47 +++++++++++++++++++++ 2 files changed, 50 insertions(+), 2 deletions(-) create mode 100644 tests/regression/82-bitfield/12-precision.c diff --git a/src/cdomain/value/util/precisionUtil.ml b/src/cdomain/value/util/precisionUtil.ml index 9f27f810c7..b226931be9 100644 --- a/src/cdomain/value/util/precisionUtil.ml +++ b/src/cdomain/value/util/precisionUtil.ml @@ -1,7 +1,7 @@ (** Integer and floating-point option and attribute handling. *) (* We define precision by the number of IntDomains activated. - * We currently have 5 types: DefExc, Interval, Enums, Congruence, IntervalSet, Bitfield*) + * We currently have 6 types: DefExc, Interval, Enums, Congruence, IntervalSet, Bitfield*) type int_precision = (bool * bool * bool * bool * bool * bool) (* Same applies for FloatDomain * We currently have only an interval type analysis *) @@ -57,7 +57,8 @@ let reset_lazy () = enums := None; congruence := None; interval_set := None; - annotation_int_enabled := None + annotation_int_enabled := None; + bitfield := None (* Thus for maximum precision we activate all Domains *) let max_int_precision : int_precision = (true, true, true, true, true, true) diff --git a/tests/regression/82-bitfield/12-precision.c b/tests/regression/82-bitfield/12-precision.c new file mode 100644 index 0000000000..8e97a4dd7e --- /dev/null +++ b/tests/regression/82-bitfield/12-precision.c @@ -0,0 +1,47 @@ +// PARAM: --enable ana.int.bitfield --enable annotation.int.enabled +#include + +#define ANY_ERROR 5 // 0b0101 +void example1(void) __attribute__((goblint_precision("no-bitfield"))); +void example2(void) __attribute__((goblint_precision("bitfield"))); + +int main() { + example1(); + example2(); +} + +void example1(){ + int state; + int r = rand() % 3; + switch (r) { + case 0: + state = 0; /* 0b0000 */ + break; + case 1: + state = 8; /* 0b1000 */ + break; + default: + state = 10; /* 0b1010 */ + break; + } + + __goblint_check((state & ANY_ERROR) == 0); //UNKNOWN +} + +void example2(){ + int state; + int r = rand() % 3; + switch (r) { + case 0: + state = 0; /* 0b0000 */ + break; + case 1: + state = 8; /* 0b1000 */ + break; + default: + state = 10; /* 0b1010 */ + break; + } + + __goblint_check((state & ANY_ERROR) == 0); //SUCCESS +} \ No newline at end of file From 65237fdea577306033e3260822783d4075c82810 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Krau=C3=9F?= Date: Thu, 19 Dec 2024 22:26:41 +0100 Subject: [PATCH 111/111] fixed overflow handling --- src/cdomain/value/cdomains/int/bitfieldDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/int/bitfieldDomain.ml b/src/cdomain/value/cdomains/int/bitfieldDomain.ml index d0c65284fd..bf4529b74e 100644 --- a/src/cdomain/value/cdomains/int/bitfieldDomain.ml +++ b/src/cdomain/value/cdomains/int/bitfieldDomain.ml @@ -245,7 +245,7 @@ module BitfieldFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Int else (top_of ik, overflow_info) - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~suppress_ovwarn t + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm ~suppress_ovwarn:(suppress_ovwarn || x = top ()) ik x let join ik b1 b2 = (norm ik @@ (BArith.join b1 b2) ) |> fst